From ce6e756f9522733da243ba53f7ebc38f7d3cb59a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Tue, 29 Apr 2025 06:25:12 +0200 Subject: [PATCH 01/50] build using nightly --- .gitignore | 1 + domaindriven-core/domaindriven-core.cabal | 70 +++++++++++------------ domaindriven-core/package.yaml | 60 +++++++++---------- stack.yaml | 15 ++++- 4 files changed, 80 insertions(+), 66 deletions(-) diff --git a/.gitignore b/.gitignore index 2e01463..eba1327 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,4 @@ stack.yaml.lock hie.yaml dist-newstyle/ .vscode +.repro diff --git a/domaindriven-core/domaindriven-core.cabal b/domaindriven-core/domaindriven-core.cabal index 85c00bc..5ddce04 100644 --- a/domaindriven-core/domaindriven-core.cabal +++ b/domaindriven-core/domaindriven-core.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.38.0. -- -- see: https://github.com/sol/hpack @@ -72,29 +72,29 @@ library ViewPatterns ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -Wall-missed-specialisations build-depends: - aeson >=2.0.3 && <2.2 - , async >=2.2.4 && <2.3 - , base >=4.7 && <5 - , bytestring >=0.11.3 && <0.12 - , containers >=0.6.5.1 && <0.7 - , deepseq >=1.4.6.1 && <1.5 - , exceptions >=0.10.4 && <0.11 - , generic-lens >=2.2.1.0 && <2.3 - , http-types >=0.12.3 && <0.13 - , microlens >=0.4.12.0 && <0.5 - , mtl >=2.2.2 && <2.4 - , postgresql-simple >=0.6.4 && <0.8 - , random >=1.2.1.1 && <1.3 + aeson + , async + , base + , bytestring + , containers + , deepseq + , exceptions + , generic-lens + , http-types + , microlens + , mtl + , postgresql-simple + , random , resource-pool - , streamly >=0.9 && <0.11 - , streamly-core ==0.2.* - , template-haskell >=2.18.0.0 && <2.21 - , time >=1.11.1 && <1.13 - , transformers >=0.5.6.2 && <0.7 - , unliftio >=0.2.0.1 && <0.3 - , unordered-containers >=0.2.19.1 && <0.3 - , uuid >=1.3.15 && <1.4 - , vector >=0.12.3.1 && <0.14 + , streamly + , streamly-core + , template-haskell + , time + , transformers + , unliftio + , unordered-containers + , uuid + , vector default-language: Haskell2010 test-suite domaindriven-core-test @@ -140,18 +140,18 @@ test-suite domaindriven-core-test ViewPatterns ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -Wall-missed-specialisations -threaded -rtsopts -with-rtsopts=-N -Wall -Wunused-packages build-depends: - aeson >=2.0.3 && <2.2 - , base >=4.7 && <5 + aeson + , base , containers , domaindriven-core - , generic-lens >=2.2.1.0 && <2.3 - , hspec >=2.9 && <2.12 - , microlens >=0.4.12.0 && <0.5 - , postgresql-simple >=0.6.4 && <0.8 - , streamly >=0.9 && <0.11 - , streamly-core ==0.2.* - , time >=1.11.1 && <1.13 - , unliftio >=0.2.0.1 && <0.3 - , unliftio-pool >=0.2.2.0 && <0.5 - , uuid >=1.3.15 && <1.4 + , generic-lens + , hspec + , microlens + , postgresql-simple + , streamly + , streamly-core + , time + , unliftio + , unliftio-pool + , uuid default-language: Haskell2010 diff --git a/domaindriven-core/package.yaml b/domaindriven-core/package.yaml index bebfb02..5eb1798 100644 --- a/domaindriven-core/package.yaml +++ b/domaindriven-core/package.yaml @@ -20,10 +20,10 @@ category: Web description: Please see the README on GitHub at dependencies: -- aeson >=2.0.3 && <2.2 -- base >=4.7 && <5 -- generic-lens >=2.2.1.0 && <2.3 -- microlens >=0.4.12.0 && <0.5 +- aeson +- base +- generic-lens +- microlens default-extensions: @@ -76,25 +76,25 @@ ghc-options: library: source-dirs: src dependencies: - - async >=2.2.4 && <2.3 - - bytestring >=0.11.3 && <0.12 - - containers >=0.6.5.1 && <0.7 - - deepseq >=1.4.6.1 && <1.5 - - exceptions >=0.10.4 && <0.11 - - http-types >=0.12.3 && <0.13 - - mtl >=2.2.2 && <2.4 - - postgresql-simple >=0.6.4 && <0.8 - - random >=1.2.1.1 && <1.3 - - streamly >=0.9 && <0.11 - - streamly-core >=0.2 && <0.3 - - template-haskell >=2.18.0.0 && <2.21 - - time >=1.11.1 && <1.13 - - transformers >=0.5.6.2 && <0.7 - - unliftio >=0.2.0.1 && <0.3 + - async + - bytestring + - containers + - deepseq + - exceptions + - http-types + - mtl + - postgresql-simple + - random + - streamly + - streamly-core + - template-haskell + - time + - transformers + - unliftio - resource-pool - - uuid >=1.3.15 && <1.4 - - unordered-containers >=0.2.19.1 && <0.3 - - vector >=0.12.3.1 && <0.14 + - uuid + - unordered-containers + - vector tests: domaindriven-core-test: main: Spec.hs @@ -109,11 +109,11 @@ tests: dependencies: - containers - domaindriven-core - - hspec >=2.9 && <2.12 - - postgresql-simple >=0.6.4 && <0.8 - - streamly >=0.9 && <0.11 - - streamly-core >=0.2 && <0.3 - - time >=1.11.1 && <1.13 - - unliftio >=0.2.0.1 && <0.3 - - unliftio-pool >=0.2.2.0 && <0.5 - - uuid >=1.3.15 && <1.4 + - hspec + - postgresql-simple + - streamly + - streamly-core + - time + - unliftio + - unliftio-pool + - uuid diff --git a/stack.yaml b/stack.yaml index d1e6466..044b9a8 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,10 +1,23 @@ -resolver: lts-22.22 +resolver: nightly-2025-04-23 packages: - domaindriven-core - domaindriven - domaindriven-examples +extra-deps: + - openapi3-3.2.4 + - servant-auth-server-0.4.9.0 + - insert-ordered-containers-0.2.6 + - servant-openapi3-2.0.1.6 + ghc-options: "$locals": -fwrite-ide-info '$everything': -haddock -hiedir=.hie + +allow-newer: true +allow-newer-deps: + - openapi3 + - servant-auth-server + - servant-openapi3 + - insert-ordered-containers From b99b19579d34eccd0249d3d447a29265b05f84f6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Tue, 29 Apr 2025 07:40:59 +0200 Subject: [PATCH 02/50] use latest nightly --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 044b9a8..21987a6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2025-04-23 +resolver: nightly-2025-04-24 packages: - domaindriven-core - domaindriven From 6b8ee0c1a3036881aab56d3a981538c5fff2dc2b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Wed, 25 Jun 2025 16:20:00 +0200 Subject: [PATCH 03/50] towards indexed model support --- domaindriven-core/domaindriven-core.cabal | 2 + domaindriven-core/package.yaml | 6 +- .../src/DomainDriven/Persistance/Class.hs | 25 ++- .../Persistance/Postgres/Internal.hs | 210 +++++++++++------- .../src/DomainDriven/Server/Server.hs | 42 ++-- 5 files changed, 182 insertions(+), 103 deletions(-) diff --git a/domaindriven-core/domaindriven-core.cabal b/domaindriven-core/domaindriven-core.cabal index 5ddce04..b605b00 100644 --- a/domaindriven-core/domaindriven-core.cabal +++ b/domaindriven-core/domaindriven-core.cabal @@ -80,6 +80,7 @@ library , deepseq , exceptions , generic-lens + , hashable , http-types , microlens , mtl @@ -89,6 +90,7 @@ library , streamly , streamly-core , template-haskell + , text , time , transformers , unliftio diff --git a/domaindriven-core/package.yaml b/domaindriven-core/package.yaml index 5eb1798..d9aabd6 100644 --- a/domaindriven-core/package.yaml +++ b/domaindriven-core/package.yaml @@ -81,19 +81,21 @@ library: - containers - deepseq - exceptions + - hashable - http-types - mtl - postgresql-simple - random + - resource-pool - streamly - streamly-core - template-haskell + - text - time - transformers - unliftio - - resource-pool - - uuid - unordered-containers + - uuid - vector tests: domaindriven-core-test: diff --git a/domaindriven-core/src/DomainDriven/Persistance/Class.hs b/domaindriven-core/src/DomainDriven/Persistance/Class.hs index 008e09a..5ad642f 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Class.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Class.hs @@ -18,14 +18,24 @@ import Streamly.Data.Stream.Prelude (Stream) import System.Random import UnliftIO import Prelude +import Data.Text (Text) +import Data.Hashable (Hashable) + +data NoIndex = NoIndex + deriving (Show, Eq, Ord, Generic, Hashable) + +newtype Indexed = Indexed Text + deriving stock (Show, Generic) + deriving newtype (Eq, Ord, Hashable) class ReadModel p where type Model p :: Type type Event p :: Type + type Index p :: Type applyEvent :: p -> Model p -> Stored (Event p) -> Model p - getModel :: HasCallStack => p -> IO (Model p) - getEventList :: p -> IO [Stored (Event p)] - getEventStream :: HasCallStack => p -> Stream IO (Stored (Event p)) + getModel :: HasCallStack => p -> Index p -> IO (Model p) + getEventList :: p -> Index p -> IO [Stored (Event p)] + getEventStream :: HasCallStack => p -> Index p -> Stream IO (Stored (Event p)) type RunCmd model event m a = (model -> m (model -> a, [event])) -> m a @@ -36,6 +46,7 @@ class ReadModel p => WriteModel p where postUpdateHook :: MonadIO m => p + -> Index p -> Model p -> [Stored (Event p)] -> m () @@ -47,6 +58,7 @@ class ReadModel p => WriteModel p where => forall m a . MonadUnliftIO m => p + -> Index p -> (Model p -> m (Model p -> a, [Event p])) -> m ( Model p @@ -62,10 +74,11 @@ runCmd => forall p m a . (WriteModel p, MonadUnliftIO m) => p + -> Index p -> RunCmd (Model p) (Event p) m a -runCmd p cmd = withFrozenCallStack $ do - (model, events, returnFun) <- transactionalUpdate p cmd - _ <- async $ postUpdateHook p model events +runCmd p index cmd = withFrozenCallStack $ do + (model, events, returnFun) <- transactionalUpdate p index cmd + _ <- async $ postUpdateHook p index model events pure $ returnFun model -- | Wrapper for stored data diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs index 5c6b35f..a09f8c9 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs @@ -13,8 +13,15 @@ import Data.Pool.Introspection as Pool import Data.Sequence (Seq (..)) import Data.Sequence qualified as Seq import Data.String +import Data.HashMap.Strict (HashMap) +import Data.Hashable (Hashable) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Maybe (fromMaybe) +import Data.HashMap.Strict qualified as HM import Data.Time import Database.PostgreSQL.Simple as PG +import Data.Generics.Labels () import Database.PostgreSQL.Simple.Cursor qualified as Cursor import DomainDriven.Persistance.Class import DomainDriven.Persistance.Postgres.Types @@ -40,6 +47,20 @@ data LogEntry | WaitForConnectionDuration NominalDiffTime OneLineCallStack deriving (Show, Generic) +class Hashable a => IsPgIndex a where + toPgIndex :: a -> Text -- FIXME: Should not be Text + fromPgIndex :: Text -> a + toQuery :: a -> Query + toQuery t = "'" <> (fromString . T.unpack . toPgIndex) t <> "'" + +instance IsPgIndex NoIndex where + toPgIndex = const "0" + fromPgIndex _ = NoIndex + +instance IsPgIndex Indexed where + toPgIndex (Indexed t) = t + fromPgIndex = Indexed + newtype OneLineCallStack = OneLineCallStack CallStack instance Show OneLineCallStack where @@ -61,23 +82,24 @@ showOnlyCallSite stack = go (getCallStack stack) _ : xs -> go xs [] -> "" -data PostgresEvent model event = PostgresEvent +data PostgresEvent model index event = PostgresEvent { connectionPool :: Pool Connection , eventTableName :: EventTableName - , modelIORef :: IORef (NumberedModel model) + , modelIORef :: IORef (HashMap index (NumberedModel model)) , app :: model -> Stored event -> model , seed :: model , chunkSize :: ChunkSize -- ^ Number of events read from postgres per batch - , updateHook :: PostgresEvent model event -> model -> [Stored event] -> IO () + , updateHook :: PostgresEvent model index event -> index -> + model -> [Stored event] -> IO () , logger :: LogEntry -> IO () } deriving (Generic) -data PostgresEventTrans model event = PostgresEventTrans +data PostgresEventTrans model index event = PostgresEventTrans { transaction :: OngoingTransaction , eventTableName :: EventTableName - , modelIORef :: IORef (NumberedModel model) + , modelIORef :: IORef (HashMap index (NumberedModel model)) , app :: model -> Stored event -> model , seed :: model , chunkSize :: ChunkSize @@ -86,16 +108,17 @@ data PostgresEventTrans model event = PostgresEventTrans } deriving (Generic) -instance FromJSON e => ReadModel (PostgresEvent m e) where - type Model (PostgresEvent m e) = m - type Event (PostgresEvent m e) = e - applyEvent pg = pg ^. field @"app" - getModel pg = withIOTrans pg getModel' +instance (IsPgIndex i, FromJSON e) => ReadModel (PostgresEvent m i e) where + type Model (PostgresEvent m i e) = m + type Index (PostgresEvent m i e) = i + type Event (PostgresEvent m i e) = e + applyEvent pg = pg ^. field @"app" + getModel pg index = withIOTrans pg (`getModel'` index) - getEventList pg = withResource (connectionPool pg) $ \conn -> - fmap fst <$> queryEvents (Pool.resource conn) (pg ^. field @"eventTableName") + getEventList pg index = withResource (connectionPool pg) $ \conn -> + fmap fst <$> queryEvents (Pool.resource conn) (pg ^. field @"eventTableName") index - getEventStream pg = withStreamReadTransaction pg getEventStream' + getEventStream pg = withStreamReadTransaction pg . flip getEventStream' getEventTableName :: EventTable -> EventTableName getEventTableName = go 0 @@ -106,32 +129,30 @@ getEventTableName = go 0 InitialVersion n -> n <> "_v" <> show (i + 1) -- | Create the table required for storing state and events, if they do not yet exist. -createEventTable - :: (FromJSON e, WriteModel (PostgresEventTrans m e)) - => PostgresEventTrans m e - -> IO () +createEventTable :: PostgresEventTrans model index event -> IO () createEventTable pgt = do - void (getModel pgt) - `catch` ( const @_ @SqlError $ do - let etName = pgt ^. field @"eventTableName" - _ <- - createEventTable' - (pgt ^. field @"transaction" . field @"connectionResource" . field @"resource") - etName - void $ refreshModel pgt - ) + void $ + createEventTable' + (pgt ^. #transaction . #connectionResource . #resource) + (pgt ^. #eventTableName) createEventTable' :: Connection -> EventTableName -> IO Int64 -createEventTable' conn eventTable = +createEventTable' conn eventTable = do + _ <- + execute_ conn $ + "create table if not exists \"" + <> fromString eventTable + <> "\" \ + \( id uuid primary key\ + \, index varchar not null\ + \, event_number bigint not null generated always as identity\ + \, timestamp timestamptz not null default now()\ + \, event jsonb not null\ + \);" execute_ conn $ - "create table if not exists \"" + "create index on \"" <> fromString eventTable - <> "\" \ - \( id uuid primary key\ - \, event_number bigint not null generated always as identity\ - \, timestamp timestamptz not null default now()\ - \, event jsonb not null\ - \);" + <> "\" (index, event_number);" retireTable :: Connection -> EventTableName -> IO () retireTable conn tableName = do @@ -166,12 +187,11 @@ simplePool getConn = do -- | Setup the persistance model and verify that the tables exist. postgresWriteModelNoMigration :: HasCallStack - => (FromJSON event, WriteModel (PostgresEventTrans model event)) => Pool Connection -> EventTableName -> (model -> Stored event -> model) -> model - -> IO (PostgresEvent model event) + -> IO (PostgresEvent model index event) postgresWriteModelNoMigration pool eventTable app' seed' = do pg <- createPostgresPersistance pool eventTable app' seed' withIOTrans pg createEventTable @@ -184,7 +204,7 @@ postgresWriteModel -> EventTable -> (model -> Stored event -> model) -> model - -> IO (PostgresEvent model event) + -> IO (PostgresEvent model index event) postgresWriteModel pool eventTable app' seed' = do pg <- createPostgresPersistance pool (getEventTableName eventTable) app' seed' withIOTrans pg $ \pgt -> runMigrations (pgt ^. field @"logger") (pgt ^. field @"transaction") eventTable @@ -230,16 +250,16 @@ runMigrations logger trans et = do void $ createEventTable' conn tableName createPostgresPersistance - :: forall event model + :: forall event model index . Pool Connection -> EventTableName -> (model -> Stored event -> model) -- ^ Apply event -> model -- ^ Initial model - -> IO (PostgresEvent model event) + -> IO (PostgresEvent model index event) createPostgresPersistance pool eventTable app' seed' = do - ref <- newIORef $ NumberedModel seed' 0 + ref <- newIORef HM.empty pure $ PostgresEvent { connectionPool = pool @@ -248,7 +268,7 @@ createPostgresPersistance pool eventTable app' seed' = do , app = app' , seed = seed' , chunkSize = 50 - , updateHook = \_ _ _ -> pure () + , updateHook = \_ _ _ _ -> pure () , logger = \case e@(DbTransactionDuration dt _) -> when (dt > 1) $ putStrLn $ "[DomainDriven] " <> show e e@(EventTableLockDuration dt _) -> when (dt > 0.5) $ putStrLn $ "[DomainDriven] " <> show e @@ -257,18 +277,22 @@ createPostgresPersistance pool eventTable app' seed' = do } queryEvents - :: FromJSON a + :: forall a index + . (IsPgIndex index, FromJSON a) => Connection -> EventTableName + -> index -> IO [(Stored a, EventNumber)] -queryEvents conn eventTable = do +queryEvents conn eventTable index = do traverse fromEventRow =<< query_ conn q where q :: PG.Query q = "select id, event_number,timestamp,event from \"" <> fromString eventTable - <> "\" order by event_number" + <> "\" where index = " + <> toQuery index + <> " order by event_number" queryEventsAfter :: FromJSON a @@ -299,12 +323,15 @@ mkEventsAfterQuery eventTable (EventNumber lastEvent) = <> fromString (show lastEvent) <> " order by event_number" -mkEventQuery :: EventTableName -> EventQuery -mkEventQuery eventTable = +mkEventQuery :: IsPgIndex index => EventTableName -> index -> EventQuery +mkEventQuery eventTable index = EventQuery $ "select id, event_number,timestamp,event from \"" <> fromString eventTable - <> "\" order by event_number" + <> "\" where index = " + <> toQuery index + <> " order by event_number" + headMay :: [a] -> Maybe a headMay = \case @@ -348,26 +375,31 @@ writeEvents conn eventTable storedEvents = do ("select coalesce(max(event_number),1) from \"" <> fromString eventTable <> "\"") getEventStream' - :: FromJSON event => PostgresEventTrans model event -> Stream IO (Stored event) -getEventStream' pgt = + :: ( FromJSON event + , IsPgIndex index + ) + => PostgresEventTrans model index event + -> index + -> Stream IO (Stored event) +getEventStream' pgt index = fst <$> mkEventStream - (pgt ^. field @"chunkSize") - (pgt ^. field @"transaction" . field @"connectionResource" . field @"resource") - (pgt ^. field @"eventTableName" . to mkEventQuery) + (pgt ^. #chunkSize) + (pgt ^. #transaction . #connectionResource . #resource) + (pgt ^. #eventTableName . to (`mkEventQuery` index)) -- | A transaction that is always rolled back at the end. -- This is useful when using cursors as they can only be used inside a transaction. withStreamReadTransaction - :: forall m a model event + :: forall m a model index event . HasCallStack => (Stream.MonadAsync m, MonadCatch m) - => PostgresEvent model event - -> (PostgresEventTrans model event -> Stream m a) + => PostgresEvent model index event + -> (PostgresEventTrans model index event -> Stream m a) -> Stream m a withStreamReadTransaction pg = Stream.bracket startTrans rollbackTrans where - startTrans :: m (PostgresEventTrans model event) + startTrans :: m (PostgresEventTrans model index event) startTrans = liftIO $ do (connR, localPool) <- takeResource (connectionPool pg) t0 <- getCurrentTime @@ -383,7 +415,7 @@ withStreamReadTransaction pg = Stream.bracket startTrans rollbackTrans , logger = pg ^. field @"logger" } - rollbackTrans :: PostgresEventTrans model event -> m () + rollbackTrans :: PostgresEventTrans model index event -> m () rollbackTrans pgt = liftIO $ do -- Nothing changes. We just need the transaction to be able to stream events. let OngoingTransaction connR localPool t0 = pgt ^. field' @"transaction" @@ -403,10 +435,10 @@ withStreamReadTransaction pg = Stream.bracket startTrans rollbackTrans destroyResource (connectionPool pg) localPool conn withIOTrans - :: forall a model event + :: forall a model index event . HasCallStack - => PostgresEvent model event - -> (PostgresEventTrans model event -> IO a) + => PostgresEvent model index event + -> (PostgresEventTrans model index event -> IO a) -> IO a withIOTrans pg f = do transactionCompleted <- newIORef False @@ -422,7 +454,7 @@ withIOTrans pg f = do writeIORef transactionCompleted True pure a where - cleanup :: IORef Bool -> PostgresEventTrans model event -> IO () + cleanup :: IORef Bool -> PostgresEventTrans model index event -> IO () cleanup transactionCompleted pgt = do let OngoingTransaction connR localPool t0 = pgt ^. field' @"transaction" conn = Pool.resource connR @@ -445,7 +477,7 @@ withIOTrans pg f = do prepareTransaction :: Pool.Resource Connection -> LocalPool Connection - -> IO (PostgresEventTrans model event) + -> IO (PostgresEventTrans model index event) prepareTransaction connR localPool = do t0 <- getCurrentTime PG.begin $ Pool.resource connR @@ -484,24 +516,38 @@ mkEventStream chunkSize conn q = do . Stream.unfoldrM step ) -getModel' :: forall e m. FromJSON e => PostgresEventTrans m e -> IO m -getModel' pgt = do - NumberedModel model lastEventNo <- readIORef (pgt ^. field @"modelIORef") +getModel' :: forall e m i. (IsPgIndex i, FromJSON e) => PostgresEventTrans m i e -> i -> IO m +getModel' pgt index = do + NumberedModel model lastEventNo <- getCurrentState pgt index hasNewEvents <- queryHasEventsAfter (pgt ^. field @"transaction" . field @"connectionResource" . field @"resource") (pgt ^. field @"eventTableName") lastEventNo - if hasNewEvents then fst <$> refreshModel pgt else pure model + if hasNewEvents then fst <$> refreshModel pgt index else pure model + +getCurrentState + :: forall pg index model + . ( IsPgIndex index + , HasField' "modelIORef" pg (IORef (HashMap index (NumberedModel model))) + , HasField' "seed" pg model + ) + => pg + -> index + -> IO (NumberedModel model) +getCurrentState pg index = + fromMaybe (NumberedModel (pg ^. field' @"seed") 0) . HM.lookup index + <$> readIORef (pg ^. field' @"modelIORef") refreshModel - :: forall m e - . FromJSON e - => PostgresEventTrans m e + :: forall m i e + . (IsPgIndex i, FromJSON e) + => PostgresEventTrans m i e + -> i -> IO (m, EventNumber) -refreshModel pgt = withExclusiveLock pgt $ do +refreshModel pgt index = withExclusiveLock pgt $ do --FIXME: we should only lock the index column of the table. -- refresh doesn't write any events but changes the state and thus needs a lock - NumberedModel model lastEventNo <- readIORef (pgt ^. field @"modelIORef") + NumberedModel model lastEventNo <- getCurrentState pgt index let eventStream = mkEventStream (pgt ^. field @"chunkSize") @@ -512,7 +558,7 @@ refreshModel pgt = withExclusiveLock pgt $ do applyModel (NumberedModel m _) (ev, evNumber) = NumberedModel ((pgt ^. field @"app") m ev) evNumber - NumberedModel newModel lastNewEventNo <- + newNumberedModel@(NumberedModel newModel lastNewEventNo) <- Stream.fold ( Fold.foldl' applyModel @@ -520,7 +566,9 @@ refreshModel pgt = withExclusiveLock pgt $ do ) eventStream - _ <- writeIORef (pgt ^. field @"modelIORef") $ NumberedModel newModel lastNewEventNo + atomicModifyIORef + (pgt ^. field @"modelIORef") + (\a -> (HM.insert index newNumberedModel a, ())) pure (newModel, lastNewEventNo) exclusiveLock :: OngoingTransaction -> EventTableName -> IO () @@ -528,7 +576,7 @@ exclusiveLock (OngoingTransaction connR _ _) etName = void $ execute_ (Pool.resource connR) ("lock \"" <> fromString etName <> "\" in exclusive mode") -withExclusiveLock :: HasCallStack => PostgresEventTrans m e -> IO a -> IO a +withExclusiveLock :: HasCallStack => PostgresEventTrans m i e -> IO a -> IO a withExclusiveLock pgt a = do t0 <- getCurrentTime exclusiveLock (pgt ^. field' @"transaction") (pgt ^. field @"eventTableName") @@ -538,14 +586,14 @@ withExclusiveLock pgt a = do EventTableLockDuration (diffUTCTime t1 t0) (OneLineCallStack callStack) pure r -instance (ToJSON e, FromJSON e) => WriteModel (PostgresEvent m e) where - postUpdateHook pg m e = liftIO $ (pg ^. field @"updateHook") pg m e +instance (IsPgIndex i, ToJSON e, FromJSON e) => WriteModel (PostgresEvent m i e) where + postUpdateHook pg i m e = liftIO $ (pg ^. field @"updateHook") pg i m e - transactionalUpdate pg cmd = withRunInIO $ \runInIO -> + transactionalUpdate pg index cmd = withRunInIO $ \runInIO -> withIOTrans pg $ \pgt -> withExclusiveLock pgt $ do - m <- getModel' pgt + m <- getModel' pgt index (returnFun, evs) <- runInIO $ cmd m - NumberedModel m' _ <- readIORef (pg ^. field @"modelIORef") + NumberedModel m' _ <- getCurrentState pg index storedEvs <- traverse toStored evs newNumberedModel <- uncurry NumberedModel @@ -559,5 +607,7 @@ instance (ToJSON e, FromJSON e) => WriteModel (PostgresEvent m e) where (pg ^. field @"eventTableName") storedEvs ) - _ <- writeIORef (pg ^. field @"modelIORef") newNumberedModel + atomicModifyIORef + (pg ^. field @"modelIORef") + (\a -> (HM.insert index newNumberedModel a, ())) pure (model newNumberedModel, storedEvs, returnFun) diff --git a/domaindriven/src/DomainDriven/Server/Server.hs b/domaindriven/src/DomainDriven/Server/Server.hs index df764fe..e110aed 100644 --- a/domaindriven/src/DomainDriven/Server/Server.hs +++ b/domaindriven/src/DomainDriven/Server/Server.hs @@ -64,14 +64,26 @@ mapServer f Delayed{..} = , .. } -data WritePersistence model event - = forall p. (Model p ~ model, Event p ~ event, WriteModel p) => WritePersistence p -data ReadPersistence model = forall p. (Model p ~ model, ReadModel p) => ReadPersistence p +data WritePersistence model index event + = forall p. + ( Model p ~ model + , Event p ~ event + , Index p ~ index + , WriteModel p + ) => + WritePersistence p +data ReadPersistence model index + = forall p. + ( Model p ~ model + , ReadModel p + , Index p ~ index + ) => + ReadPersistence p instance ( HasServer (Verb method status ctypes a) context , CanMutate method ~ 'True - , HasContextEntry context (WritePersistence model event) + , HasContextEntry context (WritePersistence model () event) ) => HasServer (Cmd' model event (Verb method status ctypes a)) context where @@ -81,13 +93,13 @@ instance hoistServerWithContext _ _ f (Cmd action) = Cmd $ \model -> f (action model) route _ context delayedServer = - case getContextEntry context :: WritePersistence model event of + case getContextEntry context :: WritePersistence model () event of WritePersistence p -> route (Proxy @(Verb method status ctypes a)) context $ mapServer ( \(Cmd server) -> do handlerRes <- - liftIO . Control.Monad.Catch.try . runCmd p $ + liftIO . Control.Monad.Catch.try . runCmd p () $ either throwIO pure <=< runHandler . server either throwError pure handlerRes ) @@ -95,7 +107,7 @@ instance instance ( HasServer (Verb method status ctypes a) context - , HasContextEntry context (ReadPersistence model) + , HasContextEntry context (ReadPersistence model ()) ) => HasServer (Query' model (Verb method status ctypes a)) context where @@ -104,17 +116,17 @@ instance hoistServerWithContext _ _ f (Query action) = Query $ \model -> f (action model) route _ context delayedServer = - case getContextEntry context :: ReadPersistence model of + case getContextEntry context :: ReadPersistence model () of ReadPersistence p -> route (Proxy @(Verb method status ctypes a)) context $ mapServer - ( \(Query server) -> server =<< liftIO (getModel p) + ( \(Query server) -> server =<< liftIO (getModel p ()) ) delayedServer instance ( HasServer (Verb method status ctypes a) context - , HasContextEntry context (ReadPersistence model) + , HasContextEntry context (ReadPersistence model ()) ) => HasServer (CbQuery' model (Verb method status ctypes a)) context where @@ -125,18 +137,18 @@ instance hoistServerWithContext _ _ f (CbQuery action) = CbQuery $ \model -> f (action model) route _ context delayedServer = - case getContextEntry context :: ReadPersistence model of + case getContextEntry context :: ReadPersistence model () of ReadPersistence p -> route (Proxy @(Verb method status ctypes a)) context $ mapServer - ( \(CbQuery server) -> server (liftIO $ getModel p) + ( \(CbQuery server) -> server (liftIO $ getModel p ()) ) delayedServer instance ( HasServer (Verb method status ctypes a) context , CanMutate method ~ 'True - , HasContextEntry context (WritePersistence model event) + , HasContextEntry context (WritePersistence model () event) ) => HasServer (CbCmd' model event (Verb method status ctypes a)) context where @@ -152,10 +164,10 @@ instance CbCmd $ \transact -> f (action transact) route _ context delayedServer = - case getContextEntry context :: WritePersistence model event of + case getContextEntry context :: WritePersistence model () event of WritePersistence p -> route (Proxy @(Verb method status ctypes a)) context $ mapServer - ( \(CbCmd server) -> server $ runCmd p + ( \(CbCmd server) -> server $ runCmd p () ) delayedServer From 5ec5845896926e205080df7eb99e7ea905be53be Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Thu, 26 Jun 2025 08:57:04 +0200 Subject: [PATCH 04/50] it compiles again --- .../Persistance/ForgetfulInMemory.hs | 56 ++++++----- .../Persistance/Postgres/Migration.hs | 97 +++++++++++-------- .../DomainDriven/Persistance/PostgresSpec.hs | 76 ++++++++------- domaindriven-examples/hierarchical/Main.hs | 1 + domaindriven-examples/simple/Main.hs | 9 +- domaindriven/src/DomainDriven.hs | 2 + .../src/DomainDriven/Server/Server.hs | 24 ++--- 7 files changed, 149 insertions(+), 116 deletions(-) diff --git a/domaindriven-core/src/DomainDriven/Persistance/ForgetfulInMemory.hs b/domaindriven-core/src/DomainDriven/Persistance/ForgetfulInMemory.hs index 9f61be3..c1c15bc 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/ForgetfulInMemory.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/ForgetfulInMemory.hs @@ -2,57 +2,65 @@ module DomainDriven.Persistance.ForgetfulInMemory where -import Data.List (foldl') import DomainDriven.Persistance.Class import GHC.Generics (Generic) import Streamly.Data.Stream.Prelude qualified as Stream import UnliftIO +import Data.Maybe (fromMaybe) +import Data.HashMap.Strict (HashMap) +import Data.Hashable (Hashable) +import Data.Generics.Labels () +import Data.HashMap.Strict qualified as HM import Prelude createForgetful - :: MonadIO m + :: forall index model event m. MonadIO m => (model -> Stored event -> model) -> model -- ^ initial model - -> m (ForgetfulInMemory model event) + -> m (ForgetfulInMemory model index event) createForgetful appEvent m0 = do - state <- newIORef m0 - evs <- newIORef [] + state <- newIORef HM.empty + evs <- newIORef HM.empty lock <- newQSem 1 - pure $ ForgetfulInMemory state appEvent m0 evs lock (\_ _ -> pure ()) + pure $ ForgetfulInMemory state appEvent m0 evs lock (\_ _ _ -> pure ()) -- | STM state without event persistance -data ForgetfulInMemory model event = ForgetfulInMemory - { stateRef :: IORef model +data ForgetfulInMemory model index event = ForgetfulInMemory + { stateRef :: IORef (HashMap index model) , apply :: model -> Stored event -> model , seed :: model - , events :: IORef [Stored event] + , events :: IORef (HashMap index [Stored event]) , lock :: QSem - , updateHook :: model -> [Stored event] -> IO () + , updateHook :: index -> model -> [Stored event] -> IO () } deriving (Generic) -instance ReadModel (ForgetfulInMemory model e) where - type Model (ForgetfulInMemory model e) = model - type Event (ForgetfulInMemory model e) = e +instance Hashable index => ReadModel (ForgetfulInMemory model index event) where + type Model (ForgetfulInMemory model index event) = model + type Event (ForgetfulInMemory model index event) = event + type Index (ForgetfulInMemory model index event) = index applyEvent = apply - getModel :: ForgetfulInMemory model e -> IO (Model (ForgetfulInMemory model e)) - getModel ff = readIORef $ stateRef ff - getEventList ff = readIORef $ events ff - getEventStream ff = + getModel :: ForgetfulInMemory model index event + -> index + -> IO model + getModel ff index = HM.lookupDefault (seed ff) index <$> readIORef (stateRef ff) + getEventList ff index = HM.lookupDefault [] index <$> readIORef (events ff) + getEventStream ff index = Stream.bracketIO - (getEventList ff) + (getEventList ff index) (const (pure ())) Stream.fromList -instance WriteModel (ForgetfulInMemory model e) where - postUpdateHook p model events = liftIO $ updateHook p model events - transactionalUpdate ff evalCmd = +instance Hashable index => WriteModel (ForgetfulInMemory model index event) where + postUpdateHook p index model events = liftIO $ updateHook p index model events + transactionalUpdate ff index evalCmd = bracket_ (waitQSem $ lock ff) (signalQSem $ lock ff) $ do - model <- readIORef $ stateRef ff + model <- HM.lookupDefault (seed ff) index <$> readIORef (stateRef ff) (returnFun, evs) <- evalCmd model storedEvs <- traverse toStored evs let newModel = foldl' (apply ff) model storedEvs - modifyIORef (events ff) (<> storedEvs) - writeIORef (stateRef ff) newModel + modifyIORef (events ff) + $ HM.alter (Just . (<> storedEvs) . fromMaybe []) index + modifyIORef (stateRef ff) $ HM.insert index newModel pure (newModel, storedEvs, returnFun) diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Migration.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Migration.hs index b069b8a..1f5f48b 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Migration.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Migration.hs @@ -1,13 +1,16 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} module DomainDriven.Persistance.Postgres.Migration where import Control.Monad import Data.Aeson +import Data.Foldable import Data.Int import Data.String import Database.PostgreSQL.Simple as PG import DomainDriven.Persistance.Class import DomainDriven.Persistance.Postgres.Internal - ( mkEventQuery + ( IsPgIndex (..) + , mkEventQuery , mkEventStream ) import DomainDriven.Persistance.Postgres.Types @@ -21,36 +24,40 @@ defaultChunkSize :: ChunkSize defaultChunkSize = 100 migrateValue1to1 - :: Connection + :: forall index + . IsPgIndex index + => Connection -> PreviousEventTableName -> EventTableName -> (Value -> Value) -> IO () -migrateValue1to1 = migrateValue1to1' defaultChunkSize +migrateValue1to1 = migrateValue1to1' @index defaultChunkSize migrateValue1to1' - :: ChunkSize + :: forall index + . IsPgIndex index + => ChunkSize -> Connection -> PreviousEventTableName -> EventTableName -> (Value -> Value) -> IO () migrateValue1to1' chunkSize conn prevTName tName f = - migrate1to1' chunkSize conn prevTName tName (fmap f) + migrate1to1' @index chunkSize conn prevTName tName (fmap f) migrate1to1 - :: forall a b - . (FromJSON a, ToJSON b) + :: forall index a b + . (FromJSON a, ToJSON b, IsPgIndex index) => Connection -> PreviousEventTableName -> EventTableName -> (Stored a -> Stored b) -> IO () -migrate1to1 = migrate1to1' defaultChunkSize +migrate1to1 = migrate1to1' @index defaultChunkSize migrate1to1' - :: forall a b - . (FromJSON a, ToJSON b) + :: forall index a b + . (FromJSON a, ToJSON b, IsPgIndex index) => ChunkSize -> Connection -> PreviousEventTableName @@ -58,21 +65,21 @@ migrate1to1' -> (Stored a -> Stored b) -> IO () migrate1to1' chunkSize conn prevTName tName f = do - migrate1toMany' chunkSize conn prevTName tName (pure . f) + migrate1toMany' @index chunkSize conn prevTName tName (pure . f) migrate1toMany - :: forall a b - . (FromJSON a, ToJSON b) + :: forall index a b + . (FromJSON a, ToJSON b, IsPgIndex index) => Connection -> PreviousEventTableName -> EventTableName -> (Stored a -> [Stored b]) -> IO () -migrate1toMany = migrate1toMany' defaultChunkSize +migrate1toMany = migrate1toMany' @index defaultChunkSize migrate1toMany' - :: forall a b - . (FromJSON a, ToJSON b) + :: forall index a b + . (FromJSON a, ToJSON b, IsPgIndex index) => ChunkSize -> Connection -> PreviousEventTableName @@ -80,22 +87,25 @@ migrate1toMany' -> (Stored a -> [Stored b]) -> IO () migrate1toMany' chunkSize conn prevTName tName f = do - migrate1toManyWithState' chunkSize conn prevTName tName (\_ a -> ((), f a)) () + migrate1toManyWithState' @index chunkSize conn prevTName tName (\_ a -> ((), f a)) () migrate1toManyWithState - :: forall a b state - . (FromJSON a, ToJSON b) + :: forall index a b state + . (FromJSON a, ToJSON b, IsPgIndex index) => Connection -> PreviousEventTableName -> EventTableName -> (state -> Stored a -> (state, [Stored b])) -> state -> IO () -migrate1toManyWithState = migrate1toManyWithState' defaultChunkSize +migrate1toManyWithState = migrate1toManyWithState' @index defaultChunkSize migrate1toManyWithState' - :: forall a b state - . (FromJSON a, ToJSON b) + :: forall index a b state + . ( FromJSON a + , ToJSON b + , IsPgIndex index + ) => ChunkSize -> Connection -> PreviousEventTableName @@ -103,29 +113,38 @@ migrate1toManyWithState' -> (state -> Stored a -> (state, [Stored b])) -> state -> IO () -migrate1toManyWithState' chunkSize conn prevTName tName f initialState = - Stream.fold (Fold.groupsOf chunkSize Fold.toList (Fold.drainMapM (liftIO . writeIt))) - . Stream.unfoldMany Unfold.fromList - . fmap snd - $ Stream.scan (Fold.foldl' (\b -> f (fst b)) (initialState, [])) - $ fmap fst - $ mkEventStream chunkSize conn (mkEventQuery prevTName) +migrate1toManyWithState' chunkSize conn prevTName tName f initialState = do + indices <- fetchAllIndices conn prevTName :: IO [index] + for_ indices $ \i -> + Stream.fold (Fold.groupsOf chunkSize Fold.toList (Fold.drainMapM (liftIO . writeIt i))) + . Stream.unfoldMany Unfold.fromList + . fmap snd + $ Stream.scan (Fold.foldl' (f . fst) (initialState, [])) + $ fst <$> mkEventStream chunkSize conn (mkEventQuery prevTName i) where - writeIt :: [Stored b] -> IO Int64 - writeIt events = + writeIt :: index -> [Stored b] -> IO Int64 + writeIt index events = PG.executeMany conn ( "insert into \"" <> fromString tName - <> "\" (id, timestamp, event) \ - \values (?, ?, ?)" + <> "\" (id, index, timestamp, event) \ + \values (?, ?, ?, ?)" ) ( fmap - ( \x -> - ( storedUUID x - , storedTimestamp x - , encode $ storedEvent x - ) - ) + (\x -> (storedUUID x, toPgIndex index, storedTimestamp x, encode $ storedEvent x)) events ) + + + +fetchAllIndices + :: forall index + . IsPgIndex index + => Connection + -> EventTableName + -> IO [index] +fetchAllIndices conn etName = fmap (fromPgIndex . fromOnly) <$> PG.query_ conn q + where + q :: PG.Query + q = "select distinct index from \"" <> fromString etName <> "\" order by index;" diff --git a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs index 15804f0..421432f 100644 --- a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs +++ b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs @@ -45,7 +45,7 @@ eventTable2 :: EventTable eventTable2 = MigrateUsing mig eventTable where mig :: PreviousEventTableName -> EventTableName -> Connection -> IO () - mig prevName name conn = migrate1to1 @Value conn prevName name id + mig prevName name conn = migrate1to1 @NoIndex @Value conn prevName name id spec :: Spec spec = do @@ -56,14 +56,15 @@ spec = do migrationSpec -- make sure migrationSpec is run last! processedEvents <- runIO $ newTVarIO (Set.empty :: Set UUID) let postHook - :: PostgresEvent TestModel TestEvent + :: PostgresEvent TestModel NoIndex TestEvent + -> NoIndex -> TestModel -> [Stored TestEvent] -> IO () - postHook p m evs = do + postHook p index m evs = do atomically $ modifyTVar processedEvents (<> Set.fromList (fmap storedUUID evs)) - when (m < 0) (void $ runCmd p $ \_ -> pure (id, [Reset])) + when (m < 0) (void $ runCmd p index $ \_ -> pure (id, [Reset])) in around (setupPersistance postHook) (postHookSpec processedEvents) around (setupPersistance noHook) migrationConcurrencySpec @@ -83,12 +84,13 @@ applyTestEvent m ev = case storedEvent ev of SubtractOne -> m - 1 Reset -> 0 -noHook :: PostgresEvent TestModel TestEvent -> TestModel -> [Stored TestEvent] -> IO () -noHook _ _ _ = pure () +noHook :: PostgresEvent TestModel NoIndex TestEvent + -> NoIndex -> TestModel -> [Stored TestEvent] -> IO () +noHook _ _ _ _ = pure () setupPersistance - :: (PostgresEvent TestModel TestEvent -> TestModel -> [Stored TestEvent] -> IO ()) - -> ((PostgresEvent TestModel TestEvent, Pool Connection) -> IO ()) + :: (PostgresEvent TestModel NoIndex TestEvent -> NoIndex -> TestModel -> [Stored TestEvent] -> IO ()) + -> ((PostgresEvent TestModel NoIndex TestEvent, Pool Connection) -> IO ()) -> IO () setupPersistance postHook test = do dropEventTables =<< mkTestConn @@ -130,7 +132,7 @@ tableNames et = case et of MigrateUsing _ next -> getEventTableName et : tableNames next InitialVersion{} -> [getEventTableName et] -writeEventsSpec :: SpecWith (PostgresEvent TestModel TestEvent, Pool Connection) +writeEventsSpec :: SpecWith (PostgresEvent TestModel NoIndex TestEvent, Pool Connection) writeEventsSpec = describe "queryEvents" $ do let ev1 :: Stored TestEvent ev1 = @@ -160,27 +162,27 @@ writeEventsSpec = describe "queryEvents" $ do evs _ <- withResource pool $ \conn -> writeEvents conn (getEventTableName eventTable) storedEvs - evs' <- getEventList p + evs' <- getEventList p NoIndex drop (length evs' - 2) (fmap storedEvent evs') `shouldBe` evs -streamingSpec :: SpecWith (PostgresEvent TestModel TestEvent, Pool Connection) +streamingSpec :: SpecWith (PostgresEvent TestModel NoIndex TestEvent, Pool Connection) streamingSpec = describe "steaming" $ do it "getEventList and getEventStream yields the same result" $ \(p, pool) -> do storedEvs <- for ([1 .. 10] :: [Int]) $ \i -> do Stored AddOne (UTCTime (fromGregorian 2020 10 15) (fromIntegral i)) <$> mkId _ <- withResource pool $ \conn -> writeEvents conn (getEventTableName eventTable) storedEvs - evList <- getEventList p - evStream <- Stream.toList $ getEventStream p + evList <- getEventList p NoIndex + evStream <- Stream.toList $ getEventStream p NoIndex -- pPrint evList evList `shouldSatisfy` (== 10) . length -- must be at least two to verify order fmap storedEvent evStream `shouldBe` fmap storedEvent evList evStream `shouldBe` evList -queryEventsSpec :: SpecWith (PostgresEvent TestModel TestEvent, Pool Connection) +queryEventsSpec :: SpecWith (PostgresEvent TestModel NoIndex TestEvent, Pool Connection) queryEventsSpec = describe "queryEvents" $ do it "Can query events" $ \(_p, pool) -> withResource pool $ \conn -> do - evs <- queryEvents @TestEvent conn (getEventTableName eventTable) + evs <- queryEvents @TestEvent conn (getEventTableName eventTable) NoIndex evs `shouldSatisfy` not . null it "Events come out in the right order" $ \(_p, pool) -> withResource pool $ \conn -> do -- write few more events before @@ -201,20 +203,20 @@ queryEventsSpec = describe "queryEvents" $ do (getEventTableName eventTable) [Stored ev2 (UTCTime (fromGregorian 2020 10 18) 1) id2] - evs <- queryEvents @TestEvent conn (getEventTableName eventTable) + evs <- queryEvents @TestEvent conn (getEventTableName eventTable) NoIndex evs `shouldSatisfy` (> 1) . length let event_numbers = fmap snd evs event_numbers `shouldSatisfy` (\n -> and $ zipWith (>) (drop 1 n) n) postHookSpec - :: TVar (Set UUID) -> SpecWith (PostgresEvent TestModel TestEvent, Pool Connection) + :: TVar (Set UUID) -> SpecWith (PostgresEvent TestModel NoIndex TestEvent, Pool Connection) postHookSpec processedEvents = describe "updateHook" $ do it "Ensure we start with empty TVar" $ \_ -> do events <- readTVarIO processedEvents events `shouldBe` Set.empty it "Post update hook is fired after events are written" $ \(p, _) -> do - i <- runCmd p $ \_ -> do + i <- runCmd p NoIndex $ \_ -> do pure (id, [AddOne, AddOne, SubtractOne]) i `shouldBe` 1 threadDelay 100000 -- Ensure the hook has time to run @@ -223,23 +225,23 @@ postHookSpec processedEvents = describe "updateHook" $ do it "Hook that resets on negative works" $ \(p, _) -> do -- the hook will check if the model is negative and reset it if so - m <- runCmd p $ \_ -> do + m <- runCmd p NoIndex $ \_ -> do pure (id, [SubtractOne, SubtractOne, SubtractOne]) m `shouldBe` (-3) threadDelay 100000 -- Ensure the hook has time to run - m' <- getModel p + m' <- getModel p NoIndex m' `shouldBe` 0 -migrationSpec :: SpecWith (PostgresEvent TestModel TestEvent, Pool Connection) +migrationSpec :: SpecWith (PostgresEvent TestModel NoIndex TestEvent, Pool Connection) migrationSpec = describe "migrate1to1" $ do it "Keeps all events when using `id` to update" $ \(_p, pool) -> do evs <- withResource pool $ \conn -> - queryEvents @TestEvent conn (getEventTableName eventTable) + queryEvents @TestEvent conn (getEventTableName eventTable) NoIndex evs `shouldSatisfy` not . null _ <- postgresWriteModel pool eventTable2 applyTestEvent 0 evs' <- withResource pool $ \conn -> - queryEvents @TestEvent conn (getEventTableName eventTable2) + queryEvents @TestEvent conn (getEventTableName eventTable2) NoIndex fmap fst evs' `shouldBe` fmap fst evs @@ -287,14 +289,14 @@ migrationSpec = describe "migrate1to1" $ do brokenExists `shouldBe` False _ -> fail "Unexpectedly lacking table versions!" -migrationConcurrencySpec :: SpecWith (PostgresEvent TestModel TestEvent, Pool Connection) +migrationConcurrencySpec :: SpecWith (PostgresEvent TestModel NoIndex TestEvent, Pool Connection) migrationConcurrencySpec = describe "Event table is locked during migration" $ do it "migrate1to1" $ \(m0, pool) -> migrationTest m0 pool mig1to1 it "migrate1toMany" $ \(m0, pool) -> migrationTest m0 pool mig1toMany it "migrate1toManyWithState" $ \(m0, pool) -> migrationTest m0 pool mig1toManyState where migrationTest - :: PostgresEvent TestModel TestEvent + :: PostgresEvent TestModel NoIndex TestEvent -> Pool Connection -> EventMigration -> IO () @@ -302,13 +304,13 @@ migrationConcurrencySpec = describe "Event table is locked during migration" $ d let cmd :: Int -> IO (Int -> Int, [TestEvent]) cmd _ = pure (id, [AddOne]) - i <- replicateM 5 (runCmd m0 cmd) + i <- replicateM 5 (runCmd m0 NoIndex cmd) length i `shouldBe` 5 (result, _) <- concurrently ( do threadDelay 100000 -- sleep a bit and let the migration start - try @IO @SqlError $ runCmd m0 cmd + try @IO @SqlError $ runCmd m0 NoIndex cmd ) ( postgresWriteModel pool @@ -321,15 +323,15 @@ migrationConcurrencySpec = describe "Event table is locked during migration" $ d Left err -> sqlErrorMsg err == "Event table has been retired." mig1to1 :: PreviousEventTableName -> EventTableName -> Connection -> IO () - mig1to1 prevName name conn = migrate1to1 @Value conn prevName name slowId + mig1to1 prevName name conn = migrate1to1 @NoIndex @Value conn prevName name slowId mig1toMany :: PreviousEventTableName -> EventTableName -> Connection -> IO () - mig1toMany prevName name conn = migrate1toMany @Value conn prevName name (pure . slowId) + mig1toMany prevName name conn = migrate1toMany @NoIndex @Value conn prevName name (pure . slowId) mig1toManyState :: PreviousEventTableName -> EventTableName -> Connection -> IO () mig1toManyState prevName name conn = do putStrLn "mig1toManyState" - migrate1toManyWithState @Value + migrate1toManyWithState @NoIndex @Value conn prevName name @@ -343,23 +345,23 @@ migrationConcurrencySpec = describe "Event table is locked during migration" $ d threadDelay 250000 pure a -loggingSpec :: SpecWith (PostgresEvent TestModel TestEvent, Pool Connection) +loggingSpec :: SpecWith (PostgresEvent TestModel NoIndex TestEvent, Pool Connection) loggingSpec = describe "Callstacks" $ do it "Callstack for runCmd reference this file" $ \(p', _) -> do (logVar, p) <- withStmLogger p' - _ <- runCmd p $ \_ -> pure (id, [AddOne]) + _ <- runCmd p NoIndex $ \_ -> pure (id, [AddOne]) referencesThisFile =<< readTVarIO logVar it "Callstack for getModel reference this file" $ \(p', _) -> do (logVar, p) <- withStmLogger p' - _ <- getModel p + _ <- getModel p NoIndex referencesThisFile =<< readTVarIO logVar it "Callstack for getEventStream references this file" $ \(p', _) -> do (logVar, p) <- withStmLogger p' - _ <- Stream.toList $ getEventStream p + _ <- Stream.toList $ getEventStream p NoIndex referencesThisFile =<< readTVarIO logVar it "Callstack for getEventList references this file" $ \(p', _) -> do (logVar, p) <- withStmLogger p' - _ <- getEventList p + _ <- getEventList p NoIndex referencesThisFile =<< readTVarIO logVar where referencesThisFile :: [LogEntry] -> IO () @@ -367,8 +369,8 @@ loggingSpec = describe "Callstacks" $ do let thisFile = "DomainDriven/Persistance/PostgresSpec.hs" logs `shouldSatisfy` all ((thisFile `L.isInfixOf`) . show) withStmLogger - :: PostgresEvent TestModel TestEvent - -> IO (TVar [LogEntry], PostgresEvent TestModel TestEvent) + :: PostgresEvent TestModel NoIndex TestEvent + -> IO (TVar [LogEntry], PostgresEvent TestModel NoIndex TestEvent) withStmLogger p = do logVar <- newTVarIO [] pure (logVar, p{logger = \s -> atomically $ modifyTVar logVar (s :)}) diff --git a/domaindriven-examples/hierarchical/Main.hs b/domaindriven-examples/hierarchical/Main.hs index d221d4d..1228678 100644 --- a/domaindriven-examples/hierarchical/Main.hs +++ b/domaindriven-examples/hierarchical/Main.hs @@ -117,6 +117,7 @@ fullServer' = DomainDrivenServer fullServer app :: ( Model p ~ FullModel , Event p ~ FullEvent + , Index p ~ NoIndex , WriteModel p ) => p diff --git a/domaindriven-examples/simple/Main.hs b/domaindriven-examples/simple/Main.hs index f8c48eb..288792f 100644 --- a/domaindriven-examples/simple/Main.hs +++ b/domaindriven-examples/simple/Main.hs @@ -61,13 +61,14 @@ counterServer = DomainDrivenServer counterServers instance ApiTagFromLabel CounterApi where apiTagFromLabel = id -app +mkWaiApp :: Model p ~ CounterModel => Event p ~ CounterEvent + => Index p ~ NoIndex => WriteModel p => p -> Application -app p = +mkWaiApp p = serveWithContext (Proxy @ServantCounterApi) (ReadPersistence p :. WritePersistence p :. EmptyContext) @@ -77,5 +78,5 @@ main :: IO () main = do let port = 7878 putStrLn $ "Running on port " <> show port - p <- createForgetful applyEvent (CounterModel 0) - run port (app p) + p <- createForgetful @NoIndex applyEvent (CounterModel 0) + run port (mkWaiApp p) diff --git a/domaindriven/src/DomainDriven.hs b/domaindriven/src/DomainDriven.hs index 5b6c093..b80ca6d 100644 --- a/domaindriven/src/DomainDriven.hs +++ b/domaindriven/src/DomainDriven.hs @@ -6,6 +6,8 @@ import DomainDriven.Persistance.Class as X ( ReadModel (..) , Stored (..) , WriteModel (..) + , Indexed (..) + , NoIndex (..) , mkId , runCmd ) diff --git a/domaindriven/src/DomainDriven/Server/Server.hs b/domaindriven/src/DomainDriven/Server/Server.hs index e110aed..d69d299 100644 --- a/domaindriven/src/DomainDriven/Server/Server.hs +++ b/domaindriven/src/DomainDriven/Server/Server.hs @@ -83,7 +83,7 @@ data ReadPersistence model index instance ( HasServer (Verb method status ctypes a) context , CanMutate method ~ 'True - , HasContextEntry context (WritePersistence model () event) + , HasContextEntry context (WritePersistence model NoIndex event) ) => HasServer (Cmd' model event (Verb method status ctypes a)) context where @@ -93,13 +93,13 @@ instance hoistServerWithContext _ _ f (Cmd action) = Cmd $ \model -> f (action model) route _ context delayedServer = - case getContextEntry context :: WritePersistence model () event of + case getContextEntry context :: WritePersistence model NoIndex event of WritePersistence p -> route (Proxy @(Verb method status ctypes a)) context $ mapServer ( \(Cmd server) -> do handlerRes <- - liftIO . Control.Monad.Catch.try . runCmd p () $ + liftIO . Control.Monad.Catch.try . runCmd p NoIndex $ either throwIO pure <=< runHandler . server either throwError pure handlerRes ) @@ -107,7 +107,7 @@ instance instance ( HasServer (Verb method status ctypes a) context - , HasContextEntry context (ReadPersistence model ()) + , HasContextEntry context (ReadPersistence model NoIndex) ) => HasServer (Query' model (Verb method status ctypes a)) context where @@ -116,17 +116,17 @@ instance hoistServerWithContext _ _ f (Query action) = Query $ \model -> f (action model) route _ context delayedServer = - case getContextEntry context :: ReadPersistence model () of + case getContextEntry context :: ReadPersistence model NoIndex of ReadPersistence p -> route (Proxy @(Verb method status ctypes a)) context $ mapServer - ( \(Query server) -> server =<< liftIO (getModel p ()) + ( \(Query server) -> server =<< liftIO (getModel p NoIndex) ) delayedServer instance ( HasServer (Verb method status ctypes a) context - , HasContextEntry context (ReadPersistence model ()) + , HasContextEntry context (ReadPersistence model NoIndex) ) => HasServer (CbQuery' model (Verb method status ctypes a)) context where @@ -137,18 +137,18 @@ instance hoistServerWithContext _ _ f (CbQuery action) = CbQuery $ \model -> f (action model) route _ context delayedServer = - case getContextEntry context :: ReadPersistence model () of + case getContextEntry context :: ReadPersistence model NoIndex of ReadPersistence p -> route (Proxy @(Verb method status ctypes a)) context $ mapServer - ( \(CbQuery server) -> server (liftIO $ getModel p ()) + ( \(CbQuery server) -> server (liftIO $ getModel p NoIndex) ) delayedServer instance ( HasServer (Verb method status ctypes a) context , CanMutate method ~ 'True - , HasContextEntry context (WritePersistence model () event) + , HasContextEntry context (WritePersistence model NoIndex event) ) => HasServer (CbCmd' model event (Verb method status ctypes a)) context where @@ -164,10 +164,10 @@ instance CbCmd $ \transact -> f (action transact) route _ context delayedServer = - case getContextEntry context :: WritePersistence model () event of + case getContextEntry context :: WritePersistence model NoIndex event of WritePersistence p -> route (Proxy @(Verb method status ctypes a)) context $ mapServer - ( \(CbCmd server) -> server $ runCmd p () + ( \(CbCmd server) -> server $ runCmd p NoIndex ) delayedServer From d25685910081b5bfc3f6cf4b77a8d26bef84a741 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Thu, 26 Jun 2025 09:10:00 +0200 Subject: [PATCH 05/50] Fix test suite --- .../Persistance/Postgres/Internal.hs | 44 ++++++++++++++++--- .../DomainDriven/Persistance/PostgresSpec.hs | 16 ++++--- 2 files changed, 47 insertions(+), 13 deletions(-) diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs index a09f8c9..ef46d23 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs @@ -349,30 +349,59 @@ queryHasEventsAfter conn eventTable (EventNumber lastEvent) = <> "\" where event_number > " <> fromString (show lastEvent) +-- writeEvents +-- :: forall a +-- . ToJSON a +-- => Connection +-- -> EventTableName +-- -> [Stored a] +-- -> IO EventNumber +-- writeEvents conn eventTable storedEvents = do +-- _ <- +-- executeMany +-- conn +-- ( "insert into \"" +-- <> fromString eventTable +-- <> "\" (id, timestamp, event) \ +-- \values (?, ?, ?)" +-- ) +-- ( fmap +-- (\x -> (storedUUID x, storedTimestamp x, encode $ storedEvent x)) +-- storedEvents +-- ) +-- foldl' max 0 . fmap fromOnly +-- <$> query_ +-- conn +-- ("select coalesce(max(event_number),1) from \"" <> fromString eventTable <> "\"") writeEvents - :: forall a - . ToJSON a + :: forall a index + . ( ToJSON a + , IsPgIndex index + ) => Connection -> EventTableName + -> index -> [Stored a] -> IO EventNumber -writeEvents conn eventTable storedEvents = do +writeEvents conn eventTable index storedEvents = do _ <- executeMany conn ( "insert into \"" <> fromString eventTable - <> "\" (id, timestamp, event) \ - \values (?, ?, ?)" + <> "\" (id, index, timestamp, event) \ + \values (?, ?, ?, ?)" ) ( fmap - (\x -> (storedUUID x, storedTimestamp x, encode $ storedEvent x)) + (\x -> (storedUUID x + , toPgIndex index, storedTimestamp x, encode $ storedEvent x)) storedEvents ) foldl' max 0 . fmap fromOnly <$> query_ conn - ("select coalesce(max(event_number),1) from \"" <> fromString eventTable <> "\"") + ("select coalesce(max(event_number),1) from \"" + <> fromString eventTable <> "\"") getEventStream' :: ( FromJSON event @@ -605,6 +634,7 @@ instance (IsPgIndex i, ToJSON e, FromJSON e) => WriteModel (PostgresEvent m i e) ( writeEvents (pgt ^. field @"transaction" . field @"connectionResource" . field @"resource") (pg ^. field @"eventTableName") + index storedEvs ) atomicModifyIORef diff --git a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs index 421432f..6d0b120 100644 --- a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs +++ b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs @@ -143,11 +143,11 @@ writeEventsSpec = describe "queryEvents" $ do } it "Can write event to database" $ \(_p, pool) -> withResource pool $ \conn -> do - i <- writeEvents conn (getEventTableName eventTable) [ev1] + i <- writeEvents conn (getEventTableName eventTable) NoIndex [ev1] i `shouldBe` 1 it "Writing the same event again fails" $ \(_p, pool) -> withResource pool $ \conn -> do - writeEvents conn (getEventTableName eventTable) [ev1] + writeEvents conn (getEventTableName eventTable) NoIndex [ev1] `shouldThrow` (== FatalError) . sqlExecStatus @@ -161,7 +161,7 @@ writeEventsSpec = describe "queryEvents" $ do (\e -> Stored e (UTCTime (fromGregorian 2020 10 15) 10) <$> mkId) evs _ <- withResource pool $ \conn -> - writeEvents conn (getEventTableName eventTable) storedEvs + writeEvents conn (getEventTableName eventTable) NoIndex storedEvs evs' <- getEventList p NoIndex drop (length evs' - 2) (fmap storedEvent evs') `shouldBe` evs @@ -171,7 +171,7 @@ streamingSpec = describe "steaming" $ do storedEvs <- for ([1 .. 10] :: [Int]) $ \i -> do Stored AddOne (UTCTime (fromGregorian 2020 10 15) (fromIntegral i)) <$> mkId _ <- withResource pool $ \conn -> - writeEvents conn (getEventTableName eventTable) storedEvs + writeEvents conn (getEventTableName eventTable) NoIndex storedEvs evList <- getEventList p NoIndex evStream <- Stream.toList $ getEventStream p NoIndex -- pPrint evList @@ -194,6 +194,7 @@ queryEventsSpec = describe "queryEvents" $ do writeEvents conn (getEventTableName eventTable) + NoIndex [Stored ev1 (UTCTime (fromGregorian 2020 10 20) 1) id1] id2 <- mkId @@ -201,6 +202,7 @@ queryEventsSpec = describe "queryEvents" $ do writeEvents conn (getEventTableName eventTable) + NoIndex [Stored ev2 (UTCTime (fromGregorian 2020 10 18) 1) id2] evs <- queryEvents @TestEvent conn (getEventTableName eventTable) NoIndex @@ -252,7 +254,8 @@ migrationSpec = describe "migrate1to1" $ do AddOne (UTCTime (fromGregorian 2020 10 15) 0) uuid - withResource pool (\conn -> writeEvents conn (getEventTableName eventTable) [ev]) + withResource pool + (\conn -> writeEvents conn (getEventTableName eventTable) NoIndex [ev]) `shouldThrow` (== FatalError) . sqlExecStatus it "But can write to the new table" $ \(_p, pool) -> do @@ -263,7 +266,8 @@ migrationSpec = describe "migrate1to1" $ do (UTCTime (fromGregorian 2020 10 15) 0) uuid - void . withResource pool $ \conn -> writeEvents conn (getEventTableName eventTable2) [ev] + void . withResource pool $ \conn -> + writeEvents conn (getEventTableName eventTable2) NoIndex [ev] it "Broken migration throws and rollbacks transaction" $ \(_, pool) -> do let eventTableBroken :: EventTable From bc991e2b1055d7f221110656c468061f832dffef Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Thu, 26 Jun 2025 10:23:16 +0200 Subject: [PATCH 06/50] Get test suite to pass --- .../Persistance/Postgres/Internal.hs | 15 +- .../DomainDriven/Persistance/PostgresSpec.hs | 40 ++++++ domaindriven/src/DomainDriven/Server/Api.hs | 54 +++++++- .../src/DomainDriven/Server/Server.hs | 130 +++++++++++++++++- stack.yaml | 2 + 5 files changed, 233 insertions(+), 8 deletions(-) diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs index ef46d23..efb09d6 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs @@ -314,12 +314,19 @@ queryEventsAfter conn eventTable (EventNumber lastEvent) = newtype EventQuery = EventQuery {getPgQuery :: PG.Query} deriving (Show, Generic) -mkEventsAfterQuery :: EventTableName -> EventNumber -> EventQuery -mkEventsAfterQuery eventTable (EventNumber lastEvent) = +mkEventsAfterQuery + :: IsPgIndex index + => EventTableName + -> index + -> EventNumber + -> EventQuery +mkEventsAfterQuery eventTable index (EventNumber lastEvent) = EventQuery $ "select id, event_number,timestamp,event from \"" <> fromString eventTable - <> "\" where event_number > " + <> "\" where index = " + <> toQuery index + <> " and event_number > " <> fromString (show lastEvent) <> " order by event_number" @@ -581,7 +588,7 @@ refreshModel pgt index = withExclusiveLock pgt $ do --FIXME: we should only lock mkEventStream (pgt ^. field @"chunkSize") (pgt ^. field @"transaction" . field @"connectionResource" . field @"resource") - (mkEventsAfterQuery (pgt ^. field @"eventTableName") lastEventNo) + (mkEventsAfterQuery (pgt ^. field @"eventTableName") index lastEventNo) applyModel :: NumberedModel m -> (Stored e, EventNumber) -> NumberedModel m applyModel (NumberedModel m _) (ev, evNumber) = diff --git a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs index 6d0b120..9d4f37d 100644 --- a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs +++ b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs @@ -69,6 +69,7 @@ spec = do around (setupPersistance noHook) migrationConcurrencySpec around (setupPersistance noHook) loggingSpec + around setupPersistanceIndexed indexedSpec type TestModel = Int @@ -105,6 +106,20 @@ setupPersistance postHook test = do , pool ) +setupPersistanceIndexed + :: ((PostgresEvent TestModel Indexed TestEvent, Pool Connection) -> IO ()) + -> IO () +setupPersistanceIndexed test = do + dropEventTables =<< mkTestConn + let stripesAndResources = 5 + poolCfg <- + setNumStripes (Just stripesAndResources) + <$> mkDefaultPoolConfig mkTestConn close 1 stripesAndResources + pool <- newPool poolCfg + p <- postgresWriteModel pool eventTable applyTestEvent 0 + test (p{chunkSize = 2}, pool) + + mkTestConn :: IO Connection mkTestConn = connect $ @@ -132,6 +147,8 @@ tableNames et = case et of MigrateUsing _ next -> getEventTableName et : tableNames next InitialVersion{} -> [getEventTableName et] + + writeEventsSpec :: SpecWith (PostgresEvent TestModel NoIndex TestEvent, Pool Connection) writeEventsSpec = describe "queryEvents" $ do let ev1 :: Stored TestEvent @@ -165,6 +182,29 @@ writeEventsSpec = describe "queryEvents" $ do evs' <- getEventList p NoIndex drop (length evs' - 2) (fmap storedEvent evs') `shouldBe` evs +indexedSpec :: SpecWith (PostgresEvent TestModel Indexed TestEvent, Pool Connection) +indexedSpec = describe "indexed" $ do + it "Indexed models are updated separately" $ \(p, pool) -> do + let evs1 = [AddOne, SubtractOne, AddOne] + evs2 = [AddOne, AddOne, AddOne] + + storedEvs1 <- + traverse + (\e -> Stored e (UTCTime (fromGregorian 2020 10 15) 10) <$> mkId) + evs1 + storedEvs2 <- + traverse + (\e -> Stored e (UTCTime (fromGregorian 2020 10 15) 10) <$> mkId) + evs2 + _ <- withResource pool $ \conn -> + writeEvents conn (getEventTableName eventTable) (Indexed "1") storedEvs1 + _ <- withResource pool $ \conn -> + writeEvents conn (getEventTableName eventTable) (Indexed "2") storedEvs2 + m1 <- getModel p (Indexed "1") + m2 <- getModel p (Indexed "2") + m1 `shouldBe` 1 + m2 `shouldBe` 3 + streamingSpec :: SpecWith (PostgresEvent TestModel NoIndex TestEvent, Pool Connection) streamingSpec = describe "steaming" $ do it "getEventList and getEventStream yields the same result" $ \(p, pool) -> do diff --git a/domaindriven/src/DomainDriven/Server/Api.hs b/domaindriven/src/DomainDriven/Server/Api.hs index 4009b7e..b3b61a3 100644 --- a/domaindriven/src/DomainDriven/Server/Api.hs +++ b/domaindriven/src/DomainDriven/Server/Api.hs @@ -28,24 +28,39 @@ type CbQuery model a = CbQuery' model (Verb 'GET 200 '[JSON] a) type Query model a = Query' model (Verb 'GET 200 '[JSON] a) data Cmd' (model :: Type) (event :: Type) (verb :: Type) - data Query' (model :: Type) (verb :: Type) - data CbQuery' (model :: Type) (verb :: Type) - data CbCmd' (model :: Type) (event :: Type) (verb :: Type) +type CmdI index model event a = CmdI' index model event (Verb 'POST 200 '[JSON] a) +type CbCmdI index model event a = CbCmdI' index model event (Verb 'POST 200 '[JSON] a) +type CbQueryI index model a = CbQueryI' index model (Verb 'GET 200 '[JSON] a) +type QueryI index model a = QueryI' index model (Verb 'GET 200 '[JSON] a) + +data CmdI' (index :: Type) (model :: Type) (event :: Type) (verb :: Type) +data QueryI' (index :: Type) (model :: Type) (verb :: Type) +data CbQueryI' (index :: Type) (model :: Type) (verb :: Type) +data CbCmdI' (index :: Type) (model :: Type) (event :: Type) (verb :: Type) + instance HasOpenApi verb => HasOpenApi (Cmd' model event verb) where toOpenApi _ = toOpenApi $ Proxy @verb +instance HasOpenApi verb => HasOpenApi (CmdI' index model event verb) where + toOpenApi _ = toOpenApi $ Proxy @verb instance HasOpenApi verb => HasOpenApi (CbCmd' model event verb) where toOpenApi _ = toOpenApi $ Proxy @verb +instance HasOpenApi verb => HasOpenApi (CbCmdI' index model event verb) where + toOpenApi _ = toOpenApi $ Proxy @verb instance HasOpenApi verb => HasOpenApi (Query' model verb) where toOpenApi _ = toOpenApi $ Proxy @verb +instance HasOpenApi verb => HasOpenApi (QueryI' index model verb) where + toOpenApi _ = toOpenApi $ Proxy @verb instance HasOpenApi verb => HasOpenApi (CbQuery' model verb) where toOpenApi _ = toOpenApi $ Proxy @verb +instance HasOpenApi verb => HasOpenApi (CbQueryI' index model verb) where + toOpenApi _ = toOpenApi $ Proxy @verb data NamedField = NamedField Symbol Type @@ -136,6 +151,7 @@ instance IsOptional (Maybe t) where instance {-# OVERLAPPABLE #-} IsOptional t where isOptional = False + instance {-# OVERLAPPING #-} HasClient m (Verb method status cts ret) @@ -144,6 +160,14 @@ instance type Client m (Cmd' model event (Verb method status cts ret)) = m ret clientWithRoute pm _ = clientWithRoute pm (Proxy @(Verb method status cts ret)) hoistClientMonad _ _ f ma = f ma +instance + {-# OVERLAPPING #-} + HasClient m (Verb method status cts ret) + => HasClient m (CmdI' index model event (Verb method status cts ret)) + where + type Client m (CmdI' index model event (Verb method status cts ret)) = m ret + clientWithRoute pm _ = clientWithRoute pm (Proxy @(Verb method status cts ret)) + hoistClientMonad _ _ f ma = f ma instance {-# OVERLAPPING #-} @@ -153,6 +177,14 @@ instance type Client m (CbCmd' model event (Verb method status cts ret)) = m ret clientWithRoute pm _ = clientWithRoute pm (Proxy @(Verb method status cts ret)) hoistClientMonad _ _ f ma = f ma +instance + {-# OVERLAPPING #-} + HasClient m (Verb method status cts ret) + => HasClient m (CbCmdI' index model event (Verb method status cts ret)) + where + type Client m (CbCmdI' index model event (Verb method status cts ret)) = m ret + clientWithRoute pm _ = clientWithRoute pm (Proxy @(Verb method status cts ret)) + hoistClientMonad _ _ f ma = f ma instance {-# OVERLAPPING #-} @@ -162,6 +194,14 @@ instance type Client m (Query' model (Verb method status cts ret)) = m ret clientWithRoute pm _ = clientWithRoute pm (Proxy @(Verb method status cts ret)) hoistClientMonad _ _ f ma = f ma +instance + {-# OVERLAPPING #-} + HasClient m (Verb method status cts ret) + => HasClient m (QueryI' index model (Verb method status cts ret)) + where + type Client m (QueryI' index model (Verb method status cts ret)) = m ret + clientWithRoute pm _ = clientWithRoute pm (Proxy @(Verb method status cts ret)) + hoistClientMonad _ _ f ma = f ma instance {-# OVERLAPPING #-} @@ -171,3 +211,11 @@ instance type Client m (CbQuery' model (Verb method status cts ret)) = m ret clientWithRoute pm _ = clientWithRoute pm (Proxy @(Verb method status cts ret)) hoistClientMonad _ _ f ma = f ma +instance + {-# OVERLAPPING #-} + HasClient m (Verb method status cts ret) + => HasClient m (CbQueryI' index model (Verb method status cts ret)) + where + type Client m (CbQueryI' index model (Verb method status cts ret)) = m ret + clientWithRoute pm _ = clientWithRoute pm (Proxy @(Verb method status cts ret)) + hoistClientMonad _ _ f ma = f ma diff --git a/domaindriven/src/DomainDriven/Server/Server.hs b/domaindriven/src/DomainDriven/Server/Server.hs index d69d299..c8b539d 100644 --- a/domaindriven/src/DomainDriven/Server/Server.hs +++ b/domaindriven/src/DomainDriven/Server/Server.hs @@ -30,7 +30,8 @@ data CbQueryServer (model :: Type) m a where CbQuery :: ((forall n. (HasCallStack, MonadIO n) => n model) -> m a) -> CbQueryServer model m a data CbCmdServer (model :: Type) (event :: Type) m a where - CbCmd :: ((forall n b. (HasCallStack, MonadUnliftIO n) => RunCmd model event n b) -> m a) -> CbCmdServer model event m a + CbCmd :: ((forall n b. (HasCallStack, MonadUnliftIO n) => + RunCmd model event n b) -> m a) -> CbCmdServer model event m a instance MonadError ServerError m => ThrowAll (CmdServer model event m a) where @@ -45,6 +46,38 @@ instance MonadError ServerError m => ThrowAll (QueryServer model m a) where instance MonadError ServerError m => ThrowAll (CbQueryServer model m a) where throwAll err = CbQuery $ \_ -> throwAll err + +data CmdServerI (index :: Type) (model :: Type) (event :: Type) m a + = CmdI index (model -> m (model -> a, [event])) + +data QueryServerI (index :: Type) (model :: Type) m a + = QueryI index (model -> m a) + +data CbQueryServerI (index :: Type) (model :: Type) m a + = CbQueryI index ((forall n. MonadIO n => n model) -> m a) + +data CbCmdServerI (index :: Type) (model :: Type) (event :: Type) m a + = CbCmdI + index + ( ( forall n b + . MonadUnliftIO n + => RunCmd model event n b + ) + -> m a + ) + +instance MonadError ServerError m => ThrowAll (CmdServerI model index event m a) where + throwAll = CmdI undefined . throwAll + +instance MonadError ServerError m => ThrowAll (CbCmdServerI model index event m a) where + throwAll err = CbCmdI undefined $ \_ -> throwAll err + +instance MonadError ServerError m => ThrowAll (QueryServerI model index m a) where + throwAll = QueryI undefined . throwAll + +instance MonadError ServerError m => ThrowAll (CbQueryServerI model index m a) where + throwAll err = CbQueryI undefined $ \_ -> throwAll err + type family CanMutate (method :: StdMethod) :: Bool where CanMutate 'GET = 'False CanMutate 'POST = 'True @@ -104,6 +137,31 @@ instance either throwError pure handlerRes ) delayedServer +instance + ( HasServer (Verb method status ctypes a) context + , CanMutate method ~ 'True + , HasContextEntry context (WritePersistence model index event) + ) + => HasServer (CmdI' index model event (Verb method status ctypes a)) context + where + type + ServerT (CmdI' index model event (Verb method status ctypes a)) m = + CmdServerI index model event m a + hoistServerWithContext _ _ f (CmdI index action) = + CmdI index $ \model -> f (action model) + + route _ context delayedServer = + case getContextEntry context :: WritePersistence model index event of + WritePersistence p -> + route (Proxy @(Verb method status ctypes a)) context $ + mapServer + ( \(CmdI index server) -> do + handlerRes <- + liftIO . Control.Monad.Catch.try . runCmd p index $ + either throwIO pure <=< runHandler . server + either throwError pure handlerRes + ) + delayedServer instance ( HasServer (Verb method status ctypes a) context @@ -123,6 +181,26 @@ instance ( \(Query server) -> server =<< liftIO (getModel p NoIndex) ) delayedServer +instance + ( HasServer (Verb method status ctypes a) context + , HasContextEntry context (ReadPersistence model index) + ) + => HasServer (QueryI' index model (Verb method status ctypes a)) context + where + type ServerT (QueryI' index model (Verb method status ctypes a)) m = + QueryServerI index model m a + + hoistServerWithContext _ _ f (QueryI index action) = + QueryI index $ \model -> f (action model) + + route _ context delayedServer = + case getContextEntry context :: ReadPersistence model index of + ReadPersistence p -> + route (Proxy @(Verb method status ctypes a)) context $ + mapServer + ( \(QueryI index server) -> server =<< liftIO (getModel p index) + ) + delayedServer instance ( HasServer (Verb method status ctypes a) context @@ -145,6 +223,28 @@ instance ) delayedServer +instance + ( HasServer (Verb method status ctypes a) context + , HasContextEntry context (ReadPersistence model index) + ) + => HasServer (CbQueryI' index model (Verb method status ctypes a)) context + where + type + ServerT (CbQueryI' index model (Verb method status ctypes a)) m = + CbQueryServerI index model m a + + hoistServerWithContext _ _ f (CbQueryI index action) = + CbQueryI index $ \model -> f (action model) + + route _ context delayedServer = + case getContextEntry context :: ReadPersistence model index of + ReadPersistence p -> + route (Proxy @(Verb method status ctypes a)) context $ + mapServer + ( \(CbQueryI index server) -> server (liftIO $ getModel p index) + ) + delayedServer + instance ( HasServer (Verb method status ctypes a) context , CanMutate method ~ 'True @@ -171,3 +271,31 @@ instance ( \(CbCmd server) -> server $ runCmd p NoIndex ) delayedServer + +instance + ( HasServer (Verb method status ctypes a) context + , CanMutate method ~ 'True + , HasContextEntry context (WritePersistence model index event) + ) + => HasServer (CbCmdI' index model event (Verb method status ctypes a)) context + where + type + ServerT (CbCmdI' index model event (Verb method status ctypes a)) m = + CbCmdServerI + index + model + event + m + a + + hoistServerWithContext _ _ f (CbCmdI index action) = + CbCmdI index $ \transact -> f (action transact) + + route _ context delayedServer = + case getContextEntry context :: WritePersistence model index event of + WritePersistence p -> + route (Proxy @(Verb method status ctypes a)) context $ + mapServer + ( \(CbCmdI index server) -> server $ runCmd p index + ) + delayedServer diff --git a/stack.yaml b/stack.yaml index 21987a6..d2a3b9d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -21,3 +21,5 @@ allow-newer-deps: - servant-auth-server - servant-openapi3 - insert-ordered-containers + +system-ghc: true From d6dd309800787a88e0668ecddcc7b7b7f222a07e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Thu, 26 Jun 2025 14:25:41 +0200 Subject: [PATCH 07/50] Writing extra tests --- domaindriven-core/domaindriven-core.cabal | 1 + domaindriven-core/package.yaml | 1 + .../DomainDriven/Persistance/PostgresSpec.hs | 46 +++++++++++++++++-- 3 files changed, 45 insertions(+), 3 deletions(-) diff --git a/domaindriven-core/domaindriven-core.cabal b/domaindriven-core/domaindriven-core.cabal index b605b00..73bc42b 100644 --- a/domaindriven-core/domaindriven-core.cabal +++ b/domaindriven-core/domaindriven-core.cabal @@ -152,6 +152,7 @@ test-suite domaindriven-core-test , postgresql-simple , streamly , streamly-core + , text , time , unliftio , unliftio-pool diff --git a/domaindriven-core/package.yaml b/domaindriven-core/package.yaml index d9aabd6..42eaeb2 100644 --- a/domaindriven-core/package.yaml +++ b/domaindriven-core/package.yaml @@ -112,6 +112,7 @@ tests: - containers - domaindriven-core - hspec + - text - postgresql-simple - streamly - streamly-core diff --git a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs index 9d4f37d..169be2f 100644 --- a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs +++ b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs @@ -17,6 +17,7 @@ import Data.Traversable import Data.UUID (UUID, nil) import Data.UUID.V4 qualified as V4 import Database.PostgreSQL.Simple +import Data.Text qualified as T import DomainDriven.Persistance.Class import DomainDriven.Persistance.Postgres import DomainDriven.Persistance.Postgres.Internal @@ -30,7 +31,7 @@ import GHC.Generics (Generic) import GHC.IO.Unsafe (unsafePerformIO) import Streamly.Data.Stream.Prelude qualified as Stream import Test.Hspec -import UnliftIO (TVar, atomically, concurrently, modifyTVar, newTVarIO, readTVarIO, try) +import UnliftIO (TVar, atomically, concurrently, modifyTVar, newTVarIO, readTVarIO, try, forConcurrently) import UnliftIO.Pool import Prelude @@ -182,9 +183,12 @@ writeEventsSpec = describe "queryEvents" $ do evs' <- getEventList p NoIndex drop (length evs' - 2) (fmap storedEvent evs') `shouldBe` evs +doit :: IO () +doit = hspec $ around setupPersistanceIndexed indexedSpec + indexedSpec :: SpecWith (PostgresEvent TestModel Indexed TestEvent, Pool Connection) -indexedSpec = describe "indexed" $ do - it "Indexed models are updated separately" $ \(p, pool) -> do +indexedSpec = describe "Indexed models" $ do + it "Models with different indices are updated separately" $ \(p, pool) -> do let evs1 = [AddOne, SubtractOne, AddOne] evs2 = [AddOne, AddOne, AddOne] @@ -204,6 +208,42 @@ indexedSpec = describe "indexed" $ do m2 <- getModel p (Indexed "2") m1 `shouldBe` 1 m2 `shouldBe` 3 + it "Updates to different indices can be done in parallel" $ \(p, pool) -> do + let testCmd :: Int -> TestModel -> IO (TestModel -> TestModel, [TestEvent]) + testCmd i m = do + threadDelay 10000 -- 0.1s delay + pure (const m, replicate i AddOne) + t0 <- getCurrentTime + models <- forConcurrently ([1 .. 20] :: [Int]) $ \i -> do + let index = Indexed (T.pack $ show i) + _ <- runCmd p index $ testCmd i + getModel p index + + t1 <- getCurrentTime + + models `shouldSatisfy` (== 20) . length + models `shouldSatisfy` (== [1,2..20]) + print $ diffUTCTime t1 t0 + diffUTCTime t1 t0 `shouldSatisfy` (> 0.1) + diffUTCTime t1 t0 `shouldSatisfy` (< 0.9) + + it "Updates to same index are done sequentially" $ \(p, pool) -> do + let testCmd :: TestModel -> IO (TestModel -> TestModel, [TestEvent]) + testCmd m = do + threadDelay 10000 -- 0.1s delay + pure (id, [AddOne, AddOne]) + t0 <- getCurrentTime + models <- forConcurrently ([1 .. 20] :: [Int]) $ \_ -> do + let index = Indexed "the same" + runCmd p index testCmd + + t1 <- getCurrentTime + + models `shouldSatisfy` (== 20) . length + models `shouldSatisfy` (== [2,4..40]) + print $ diffUTCTime t1 t0 + diffUTCTime t1 t0 `shouldSatisfy` (> 20 * 0.1) + streamingSpec :: SpecWith (PostgresEvent TestModel NoIndex TestEvent, Pool Connection) streamingSpec = describe "steaming" $ do From 5d392b67eb666993253b7fb09aaac030e2028a7a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Thu, 26 Jun 2025 14:38:44 +0200 Subject: [PATCH 08/50] Sequential writes on same index works --- .../src/DomainDriven/Persistance/Postgres/Internal.hs | 2 +- .../test/DomainDriven/Persistance/PostgresSpec.hs | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs index efb09d6..91d9967 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs @@ -614,8 +614,8 @@ exclusiveLock (OngoingTransaction connR _ _) etName = withExclusiveLock :: HasCallStack => PostgresEventTrans m i e -> IO a -> IO a withExclusiveLock pgt a = do - t0 <- getCurrentTime exclusiveLock (pgt ^. field' @"transaction") (pgt ^. field @"eventTableName") + t0 <- getCurrentTime r <- a t1 <- getCurrentTime pgt ^. field' @"logger" $ diff --git a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs index 169be2f..a518794 100644 --- a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs +++ b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs @@ -211,7 +211,7 @@ indexedSpec = describe "Indexed models" $ do it "Updates to different indices can be done in parallel" $ \(p, pool) -> do let testCmd :: Int -> TestModel -> IO (TestModel -> TestModel, [TestEvent]) testCmd i m = do - threadDelay 10000 -- 0.1s delay + threadDelay 100000 -- 0.1s delay pure (const m, replicate i AddOne) t0 <- getCurrentTime models <- forConcurrently ([1 .. 20] :: [Int]) $ \i -> do @@ -222,7 +222,7 @@ indexedSpec = describe "Indexed models" $ do t1 <- getCurrentTime models `shouldSatisfy` (== 20) . length - models `shouldSatisfy` (== [1,2..20]) + models `shouldSatisfy` (== [1,2..20]) . L.sort print $ diffUTCTime t1 t0 diffUTCTime t1 t0 `shouldSatisfy` (> 0.1) diffUTCTime t1 t0 `shouldSatisfy` (< 0.9) @@ -230,7 +230,7 @@ indexedSpec = describe "Indexed models" $ do it "Updates to same index are done sequentially" $ \(p, pool) -> do let testCmd :: TestModel -> IO (TestModel -> TestModel, [TestEvent]) testCmd m = do - threadDelay 10000 -- 0.1s delay + threadDelay 100000 -- 0.1s delay pure (id, [AddOne, AddOne]) t0 <- getCurrentTime models <- forConcurrently ([1 .. 20] :: [Int]) $ \_ -> do @@ -240,7 +240,7 @@ indexedSpec = describe "Indexed models" $ do t1 <- getCurrentTime models `shouldSatisfy` (== 20) . length - models `shouldSatisfy` (== [2,4..40]) + models `shouldSatisfy` (== [2,4..40]) . L.sort print $ diffUTCTime t1 t0 diffUTCTime t1 t0 `shouldSatisfy` (> 20 * 0.1) From 1db7e5e0982bbcd96fc2154850bcf97823e69fd5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Thu, 26 Jun 2025 15:50:12 +0200 Subject: [PATCH 09/50] Use advisory locks --- .../Persistance/Postgres/Internal.hs | 23 ++++++++++--------- .../DomainDriven/Persistance/PostgresSpec.hs | 20 ++++++++-------- 2 files changed, 21 insertions(+), 22 deletions(-) diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs index 91d9967..c47bc5f 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs @@ -14,7 +14,7 @@ import Data.Sequence (Seq (..)) import Data.Sequence qualified as Seq import Data.String import Data.HashMap.Strict (HashMap) -import Data.Hashable (Hashable) +import Data.Hashable (Hashable, hash) import Data.Text (Text) import Data.Text qualified as T import Data.Maybe (fromMaybe) @@ -232,7 +232,7 @@ runMigrations logger trans et = do -- Ensure migrations are done up until the previous table runMigrations logger trans prevEt -- Then lock lock the previous table before we start - exclusiveLock trans (getEventTableName prevEt) + exclusiveLock trans (getEventTableName prevEt) NoIndex t0 <- getCurrentTime createTable mig (getEventTableName prevEt) (getEventTableName et) conn @@ -581,7 +581,7 @@ refreshModel => PostgresEventTrans m i e -> i -> IO (m, EventNumber) -refreshModel pgt index = withExclusiveLock pgt $ do --FIXME: we should only lock the index column of the table. +refreshModel pgt index = withExclusiveLock pgt index $ do -- refresh doesn't write any events but changes the state and thus needs a lock NumberedModel model lastEventNo <- getCurrentState pgt index let eventStream = @@ -607,14 +607,15 @@ refreshModel pgt index = withExclusiveLock pgt $ do --FIXME: we should only lock (\a -> (HM.insert index newNumberedModel a, ())) pure (newModel, lastNewEventNo) -exclusiveLock :: OngoingTransaction -> EventTableName -> IO () -exclusiveLock (OngoingTransaction connR _ _) etName = - void $ - execute_ (Pool.resource connR) ("lock \"" <> fromString etName <> "\" in exclusive mode") +exclusiveLock :: IsPgIndex i => OngoingTransaction -> EventTableName -> i -> IO () +exclusiveLock (OngoingTransaction connR _ _) _etName index = do + -- We use advisory locks in favor of row level locks as we would not have the ability + -- to lock an index before the first event is written with row level locks. + void $ (query (Pool.resource connR) "SELECT pg_advisory_xact_lock(?)" (Only (fromIntegral (hash index) :: Int64)) :: IO [Only ()]) -withExclusiveLock :: HasCallStack => PostgresEventTrans m i e -> IO a -> IO a -withExclusiveLock pgt a = do - exclusiveLock (pgt ^. field' @"transaction") (pgt ^. field @"eventTableName") +withExclusiveLock :: (HasCallStack, IsPgIndex i) => PostgresEventTrans m i e -> i -> IO a -> IO a +withExclusiveLock pgt index a = do + exclusiveLock (pgt ^. field' @"transaction") (pgt ^. field @"eventTableName") index t0 <- getCurrentTime r <- a t1 <- getCurrentTime @@ -626,7 +627,7 @@ instance (IsPgIndex i, ToJSON e, FromJSON e) => WriteModel (PostgresEvent m i e) postUpdateHook pg i m e = liftIO $ (pg ^. field @"updateHook") pg i m e transactionalUpdate pg index cmd = withRunInIO $ \runInIO -> - withIOTrans pg $ \pgt -> withExclusiveLock pgt $ do + withIOTrans pg $ \pgt -> withExclusiveLock pgt index $ do m <- getModel' pgt index (returnFun, evs) <- runInIO $ cmd m NumberedModel m' _ <- getCurrentState pg index diff --git a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs index a518794..08f84e9 100644 --- a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs +++ b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs @@ -183,9 +183,6 @@ writeEventsSpec = describe "queryEvents" $ do evs' <- getEventList p NoIndex drop (length evs' - 2) (fmap storedEvent evs') `shouldBe` evs -doit :: IO () -doit = hspec $ around setupPersistanceIndexed indexedSpec - indexedSpec :: SpecWith (PostgresEvent TestModel Indexed TestEvent, Pool Connection) indexedSpec = describe "Indexed models" $ do it "Models with different indices are updated separately" $ \(p, pool) -> do @@ -208,16 +205,17 @@ indexedSpec = describe "Indexed models" $ do m2 <- getModel p (Indexed "2") m1 `shouldBe` 1 m2 `shouldBe` 3 - it "Updates to different indices can be done in parallel" $ \(p, pool) -> do + + it "Updates to different indices can be done in parallel" $ \(p, _pool) -> do + -- This may fail in GHCI. Run it with stack test. let testCmd :: Int -> TestModel -> IO (TestModel -> TestModel, [TestEvent]) - testCmd i m = do + testCmd i _m = do threadDelay 100000 -- 0.1s delay - pure (const m, replicate i AddOne) + pure (id, replicate i AddOne) t0 <- getCurrentTime models <- forConcurrently ([1 .. 20] :: [Int]) $ \i -> do let index = Indexed (T.pack $ show i) - _ <- runCmd p index $ testCmd i - getModel p index + runCmd p index $ testCmd i t1 <- getCurrentTime @@ -225,11 +223,11 @@ indexedSpec = describe "Indexed models" $ do models `shouldSatisfy` (== [1,2..20]) . L.sort print $ diffUTCTime t1 t0 diffUTCTime t1 t0 `shouldSatisfy` (> 0.1) - diffUTCTime t1 t0 `shouldSatisfy` (< 0.9) + diffUTCTime t1 t0 `shouldSatisfy` (< 1.9) - it "Updates to same index are done sequentially" $ \(p, pool) -> do + it "Updates to same index are done sequentially" $ \(p, _pool) -> do let testCmd :: TestModel -> IO (TestModel -> TestModel, [TestEvent]) - testCmd m = do + testCmd _m = do threadDelay 100000 -- 0.1s delay pure (id, [AddOne, AddOne]) t0 <- getCurrentTime From 3a399fb75986d85b3e8b0f3fda86dbf27190a773 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Thu, 26 Jun 2025 16:16:26 +0200 Subject: [PATCH 10/50] fix dependencies --- domaindriven-core/domaindriven-core.cabal | 13 +-- domaindriven-core/package.yaml | 17 ++-- .../domaindriven-examples.cabal | 46 +--------- domaindriven-examples/package.yaml | 27 ++---- domaindriven/domaindriven.cabal | 90 +------------------ domaindriven/package.yaml | 76 +++++++--------- 6 files changed, 48 insertions(+), 221 deletions(-) diff --git a/domaindriven-core/domaindriven-core.cabal b/domaindriven-core/domaindriven-core.cabal index 73bc42b..995f323 100644 --- a/domaindriven-core/domaindriven-core.cabal +++ b/domaindriven-core/domaindriven-core.cabal @@ -70,18 +70,15 @@ library TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -Wall-missed-specialisations + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -Wall-missed-specialisations build-depends: aeson - , async , base - , bytestring , containers , deepseq , exceptions , generic-lens , hashable - , http-types , microlens , mtl , postgresql-simple @@ -89,14 +86,11 @@ library , resource-pool , streamly , streamly-core - , template-haskell , text , time - , transformers , unliftio , unordered-containers , uuid - , vector default-language: Haskell2010 test-suite domaindriven-core-test @@ -140,18 +134,15 @@ test-suite domaindriven-core-test TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -Wall-missed-specialisations -threaded -rtsopts -with-rtsopts=-N -Wall -Wunused-packages + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -Wall-missed-specialisations -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: aeson , base , containers , domaindriven-core - , generic-lens , hspec - , microlens , postgresql-simple , streamly - , streamly-core , text , time , unliftio diff --git a/domaindriven-core/package.yaml b/domaindriven-core/package.yaml index 42eaeb2..02612cf 100644 --- a/domaindriven-core/package.yaml +++ b/domaindriven-core/package.yaml @@ -22,8 +22,6 @@ description: Please see the README on GitHub at dependencies: -- aeson - base -- containers -- deepseq -- exceptions -- openapi3 -- servant-server -- servant-client-core -- servant -- text +- aeson - domaindriven-core +- exceptions - generics-sop -- constraints -- servant-openapi3 +- openapi3 - optics +- servant - servant-auth-server +- servant-client-core +- servant-openapi3 +- servant-server +- text default-extensions: @@ -74,6 +71,7 @@ default-extensions: ghc-options: - -Wall +- -Werror - -Wcompat - -Widentities - -Wincomplete-record-updates @@ -88,43 +86,29 @@ ghc-options: library: source-dirs: src dependencies: - - async - bytestring - - generic-lens - - http-types - - microlens - mtl - - postgresql-simple - - random - - streamly - - template-haskell - - time - - transformers - unliftio - - resource-pool - - unordered-containers - uuid - - vector -tests: - domaindriven-test: - main: Spec.hs - source-dirs: - - test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -Wall - - -Wunused-packages - dependencies: - - async - - domaindriven - - hspec - - http-client - - mtl - - QuickCheck - - quickcheck-arbitrary-adt - - quickcheck-classes - - servant-client - - warp +#tests: +# domaindriven-test: +# main: Spec.hs +# source-dirs: +# - test +# ghc-options: +# - -threaded +# - -rtsopts +# - -with-rtsopts=-N +# - -Wall +# dependencies: +# - async +# - domaindriven +# - hspec +# - http-client +# - mtl +# - QuickCheck +# - quickcheck-arbitrary-adt +# - quickcheck-classes +# - servant-client +# - warp From 92cdf125845998a4a4cbdb5b4cb015c587f5f30d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Thu, 26 Jun 2025 16:29:38 +0200 Subject: [PATCH 11/50] most consistent parameter order --- domaindriven-core/domaindriven-core.cabal | 4 +- domaindriven-core/package.yaml | 1 - .../Persistance/Postgres/Internal.hs | 112 +++++++++++------- .../DomainDriven/Persistance/PostgresSpec.hs | 32 ++--- .../domaindriven-examples.cabal | 4 +- domaindriven-examples/package.yaml | 1 - domaindriven/domaindriven.cabal | 2 +- domaindriven/package.yaml | 1 - 8 files changed, 88 insertions(+), 69 deletions(-) diff --git a/domaindriven-core/domaindriven-core.cabal b/domaindriven-core/domaindriven-core.cabal index 995f323..758f7c9 100644 --- a/domaindriven-core/domaindriven-core.cabal +++ b/domaindriven-core/domaindriven-core.cabal @@ -70,7 +70,7 @@ library TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -Wall-missed-specialisations + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages build-depends: aeson , base @@ -134,7 +134,7 @@ test-suite domaindriven-core-test TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -Wall-missed-specialisations -threaded -rtsopts -with-rtsopts=-N -Wall + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: aeson , base diff --git a/domaindriven-core/package.yaml b/domaindriven-core/package.yaml index 02612cf..9d251cd 100644 --- a/domaindriven-core/package.yaml +++ b/domaindriven-core/package.yaml @@ -70,7 +70,6 @@ ghc-options: - -Wincomplete-record-updates - -Wincomplete-patterns - -Wunused-packages -- -Wall-missed-specialisations library: source-dirs: src diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs index c47bc5f..2fb095b 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs @@ -6,22 +6,22 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Data.Aeson import Data.Foldable +import Data.Generics.Labels () import Data.Generics.Product +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM +import Data.Hashable (Hashable, hash) import Data.IORef import Data.Int +import Data.Maybe (fromMaybe) import Data.Pool.Introspection as Pool import Data.Sequence (Seq (..)) import Data.Sequence qualified as Seq import Data.String -import Data.HashMap.Strict (HashMap) -import Data.Hashable (Hashable, hash) import Data.Text (Text) import Data.Text qualified as T -import Data.Maybe (fromMaybe) -import Data.HashMap.Strict qualified as HM import Data.Time import Database.PostgreSQL.Simple as PG -import Data.Generics.Labels () import Database.PostgreSQL.Simple.Cursor qualified as Cursor import DomainDriven.Persistance.Class import DomainDriven.Persistance.Postgres.Types @@ -82,7 +82,7 @@ showOnlyCallSite stack = go (getCallStack stack) _ : xs -> go xs [] -> "" -data PostgresEvent model index event = PostgresEvent +data PostgresEvent index model event = PostgresEvent { connectionPool :: Pool Connection , eventTableName :: EventTableName , modelIORef :: IORef (HashMap index (NumberedModel model)) @@ -90,13 +90,17 @@ data PostgresEvent model index event = PostgresEvent , seed :: model , chunkSize :: ChunkSize -- ^ Number of events read from postgres per batch - , updateHook :: PostgresEvent model index event -> index -> - model -> [Stored event] -> IO () + , updateHook + :: PostgresEvent index model event + -> index + -> model + -> [Stored event] + -> IO () , logger :: LogEntry -> IO () } deriving (Generic) -data PostgresEventTrans model index event = PostgresEventTrans +data PostgresEventTrans index model event = PostgresEventTrans { transaction :: OngoingTransaction , eventTableName :: EventTableName , modelIORef :: IORef (HashMap index (NumberedModel model)) @@ -108,17 +112,17 @@ data PostgresEventTrans model index event = PostgresEventTrans } deriving (Generic) -instance (IsPgIndex i, FromJSON e) => ReadModel (PostgresEvent m i e) where - type Model (PostgresEvent m i e) = m - type Index (PostgresEvent m i e) = i - type Event (PostgresEvent m i e) = e - applyEvent pg = pg ^. field @"app" +instance (IsPgIndex i, FromJSON e) => ReadModel (PostgresEvent i m e) where + type Model (PostgresEvent i m e) = m + type Index (PostgresEvent i m e) = i + type Event (PostgresEvent i m e) = e + applyEvent pg = pg ^. field @"app" getModel pg index = withIOTrans pg (`getModel'` index) getEventList pg index = withResource (connectionPool pg) $ \conn -> fmap fst <$> queryEvents (Pool.resource conn) (pg ^. field @"eventTableName") index - getEventStream pg = withStreamReadTransaction pg . flip getEventStream' + getEventStream pg = withStreamReadTransaction pg . flip getEventStream' getEventTableName :: EventTable -> EventTableName getEventTableName = go 0 @@ -129,11 +133,11 @@ getEventTableName = go 0 InitialVersion n -> n <> "_v" <> show (i + 1) -- | Create the table required for storing state and events, if they do not yet exist. -createEventTable :: PostgresEventTrans model index event -> IO () +createEventTable :: PostgresEventTrans index model event -> IO () createEventTable pgt = do void $ createEventTable' - (pgt ^. #transaction . #connectionResource . #resource) + (pgt ^. #transaction . #connectionResource . #resource) (pgt ^. #eventTableName) createEventTable' :: Connection -> EventTableName -> IO Int64 @@ -191,7 +195,7 @@ postgresWriteModelNoMigration -> EventTableName -> (model -> Stored event -> model) -> model - -> IO (PostgresEvent model index event) + -> IO (PostgresEvent index model event) postgresWriteModelNoMigration pool eventTable app' seed' = do pg <- createPostgresPersistance pool eventTable app' seed' withIOTrans pg createEventTable @@ -204,7 +208,7 @@ postgresWriteModel -> EventTable -> (model -> Stored event -> model) -> model - -> IO (PostgresEvent model index event) + -> IO (PostgresEvent index model event) postgresWriteModel pool eventTable app' seed' = do pg <- createPostgresPersistance pool (getEventTableName eventTable) app' seed' withIOTrans pg $ \pgt -> runMigrations (pgt ^. field @"logger") (pgt ^. field @"transaction") eventTable @@ -250,14 +254,14 @@ runMigrations logger trans et = do void $ createEventTable' conn tableName createPostgresPersistance - :: forall event model index + :: forall event index model . Pool Connection -> EventTableName -> (model -> Stored event -> model) -- ^ Apply event -> model -- ^ Initial model - -> IO (PostgresEvent model index event) + -> IO (PostgresEvent index model event) createPostgresPersistance pool eventTable app' seed' = do ref <- newIORef HM.empty pure $ @@ -339,7 +343,6 @@ mkEventQuery eventTable index = <> toQuery index <> " order by event_number" - headMay :: [a] -> Maybe a headMay = \case a : _ -> Just a @@ -400,21 +403,28 @@ writeEvents conn eventTable index storedEvents = do \values (?, ?, ?, ?)" ) ( fmap - (\x -> (storedUUID x - , toPgIndex index, storedTimestamp x, encode $ storedEvent x)) + ( \x -> + ( storedUUID x + , toPgIndex index + , storedTimestamp x + , encode $ storedEvent x + ) + ) storedEvents ) foldl' max 0 . fmap fromOnly <$> query_ conn - ("select coalesce(max(event_number),1) from \"" - <> fromString eventTable <> "\"") + ( "select coalesce(max(event_number),1) from \"" + <> fromString eventTable + <> "\"" + ) getEventStream' :: ( FromJSON event , IsPgIndex index ) - => PostgresEventTrans model index event + => PostgresEventTrans index model event -> index -> Stream IO (Stored event) getEventStream' pgt index = @@ -427,15 +437,15 @@ getEventStream' pgt index = -- | A transaction that is always rolled back at the end. -- This is useful when using cursors as they can only be used inside a transaction. withStreamReadTransaction - :: forall m a model index event + :: forall m a index model event . HasCallStack => (Stream.MonadAsync m, MonadCatch m) - => PostgresEvent model index event - -> (PostgresEventTrans model index event -> Stream m a) + => PostgresEvent index model event + -> (PostgresEventTrans index model event -> Stream m a) -> Stream m a withStreamReadTransaction pg = Stream.bracket startTrans rollbackTrans where - startTrans :: m (PostgresEventTrans model index event) + startTrans :: m (PostgresEventTrans index model event) startTrans = liftIO $ do (connR, localPool) <- takeResource (connectionPool pg) t0 <- getCurrentTime @@ -451,7 +461,7 @@ withStreamReadTransaction pg = Stream.bracket startTrans rollbackTrans , logger = pg ^. field @"logger" } - rollbackTrans :: PostgresEventTrans model index event -> m () + rollbackTrans :: PostgresEventTrans index model event -> m () rollbackTrans pgt = liftIO $ do -- Nothing changes. We just need the transaction to be able to stream events. let OngoingTransaction connR localPool t0 = pgt ^. field' @"transaction" @@ -471,10 +481,10 @@ withStreamReadTransaction pg = Stream.bracket startTrans rollbackTrans destroyResource (connectionPool pg) localPool conn withIOTrans - :: forall a model index event + :: forall a index model event . HasCallStack - => PostgresEvent model index event - -> (PostgresEventTrans model index event -> IO a) + => PostgresEvent index model event + -> (PostgresEventTrans index model event -> IO a) -> IO a withIOTrans pg f = do transactionCompleted <- newIORef False @@ -490,7 +500,7 @@ withIOTrans pg f = do writeIORef transactionCompleted True pure a where - cleanup :: IORef Bool -> PostgresEventTrans model index event -> IO () + cleanup :: IORef Bool -> PostgresEventTrans index model event -> IO () cleanup transactionCompleted pgt = do let OngoingTransaction connR localPool t0 = pgt ^. field' @"transaction" conn = Pool.resource connR @@ -513,7 +523,7 @@ withIOTrans pg f = do prepareTransaction :: Pool.Resource Connection -> LocalPool Connection - -> IO (PostgresEventTrans model index event) + -> IO (PostgresEventTrans index model event) prepareTransaction connR localPool = do t0 <- getCurrentTime PG.begin $ Pool.resource connR @@ -552,7 +562,12 @@ mkEventStream chunkSize conn q = do . Stream.unfoldrM step ) -getModel' :: forall e m i. (IsPgIndex i, FromJSON e) => PostgresEventTrans m i e -> i -> IO m +getModel' + :: forall e i m + . (IsPgIndex i, FromJSON e) + => PostgresEventTrans i m e + -> i + -> IO m getModel' pgt index = do NumberedModel model lastEventNo <- getCurrentState pgt index hasNewEvents <- @@ -576,9 +591,9 @@ getCurrentState pg index = <$> readIORef (pg ^. field' @"modelIORef") refreshModel - :: forall m i e + :: forall i m e . (IsPgIndex i, FromJSON e) - => PostgresEventTrans m i e + => PostgresEventTrans i m e -> i -> IO (m, EventNumber) refreshModel pgt index = withExclusiveLock pgt index $ do @@ -603,17 +618,24 @@ refreshModel pgt index = withExclusiveLock pgt index $ do eventStream atomicModifyIORef - (pgt ^. field @"modelIORef") - (\a -> (HM.insert index newNumberedModel a, ())) + (pgt ^. field @"modelIORef") + (\a -> (HM.insert index newNumberedModel a, ())) pure (newModel, lastNewEventNo) exclusiveLock :: IsPgIndex i => OngoingTransaction -> EventTableName -> i -> IO () exclusiveLock (OngoingTransaction connR _ _) _etName index = do -- We use advisory locks in favor of row level locks as we would not have the ability -- to lock an index before the first event is written with row level locks. - void $ (query (Pool.resource connR) "SELECT pg_advisory_xact_lock(?)" (Only (fromIntegral (hash index) :: Int64)) :: IO [Only ()]) + void $ + ( query + (Pool.resource connR) + "SELECT pg_advisory_xact_lock(?)" + (Only (fromIntegral (hash index) :: Int64)) + :: IO [Only ()] + ) -withExclusiveLock :: (HasCallStack, IsPgIndex i) => PostgresEventTrans m i e -> i -> IO a -> IO a +withExclusiveLock + :: (HasCallStack, IsPgIndex i) => PostgresEventTrans i m e -> i -> IO a -> IO a withExclusiveLock pgt index a = do exclusiveLock (pgt ^. field' @"transaction") (pgt ^. field @"eventTableName") index t0 <- getCurrentTime @@ -623,7 +645,7 @@ withExclusiveLock pgt index a = do EventTableLockDuration (diffUTCTime t1 t0) (OneLineCallStack callStack) pure r -instance (IsPgIndex i, ToJSON e, FromJSON e) => WriteModel (PostgresEvent m i e) where +instance (IsPgIndex i, ToJSON e, FromJSON e) => WriteModel (PostgresEvent i m e) where postUpdateHook pg i m e = liftIO $ (pg ^. field @"updateHook") pg i m e transactionalUpdate pg index cmd = withRunInIO $ \runInIO -> diff --git a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs index 08f84e9..d8d8d31 100644 --- a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs +++ b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs @@ -57,7 +57,7 @@ spec = do migrationSpec -- make sure migrationSpec is run last! processedEvents <- runIO $ newTVarIO (Set.empty :: Set UUID) let postHook - :: PostgresEvent TestModel NoIndex TestEvent + :: PostgresEvent NoIndex TestModel TestEvent -> NoIndex -> TestModel -> [Stored TestEvent] @@ -86,13 +86,13 @@ applyTestEvent m ev = case storedEvent ev of SubtractOne -> m - 1 Reset -> 0 -noHook :: PostgresEvent TestModel NoIndex TestEvent +noHook :: PostgresEvent NoIndex TestModel TestEvent -> NoIndex -> TestModel -> [Stored TestEvent] -> IO () noHook _ _ _ _ = pure () setupPersistance - :: (PostgresEvent TestModel NoIndex TestEvent -> NoIndex -> TestModel -> [Stored TestEvent] -> IO ()) - -> ((PostgresEvent TestModel NoIndex TestEvent, Pool Connection) -> IO ()) + :: (PostgresEvent NoIndex TestModel TestEvent -> NoIndex -> TestModel -> [Stored TestEvent] -> IO ()) + -> ((PostgresEvent NoIndex TestModel TestEvent, Pool Connection) -> IO ()) -> IO () setupPersistance postHook test = do dropEventTables =<< mkTestConn @@ -108,7 +108,7 @@ setupPersistance postHook test = do ) setupPersistanceIndexed - :: ((PostgresEvent TestModel Indexed TestEvent, Pool Connection) -> IO ()) + :: ((PostgresEvent Indexed TestModel TestEvent, Pool Connection) -> IO ()) -> IO () setupPersistanceIndexed test = do dropEventTables =<< mkTestConn @@ -150,7 +150,7 @@ tableNames et = case et of -writeEventsSpec :: SpecWith (PostgresEvent TestModel NoIndex TestEvent, Pool Connection) +writeEventsSpec :: SpecWith (PostgresEvent NoIndex TestModel TestEvent, Pool Connection) writeEventsSpec = describe "queryEvents" $ do let ev1 :: Stored TestEvent ev1 = @@ -183,7 +183,7 @@ writeEventsSpec = describe "queryEvents" $ do evs' <- getEventList p NoIndex drop (length evs' - 2) (fmap storedEvent evs') `shouldBe` evs -indexedSpec :: SpecWith (PostgresEvent TestModel Indexed TestEvent, Pool Connection) +indexedSpec :: SpecWith (PostgresEvent Indexed TestModel TestEvent, Pool Connection) indexedSpec = describe "Indexed models" $ do it "Models with different indices are updated separately" $ \(p, pool) -> do let evs1 = [AddOne, SubtractOne, AddOne] @@ -243,7 +243,7 @@ indexedSpec = describe "Indexed models" $ do diffUTCTime t1 t0 `shouldSatisfy` (> 20 * 0.1) -streamingSpec :: SpecWith (PostgresEvent TestModel NoIndex TestEvent, Pool Connection) +streamingSpec :: SpecWith (PostgresEvent NoIndex TestModel TestEvent, Pool Connection) streamingSpec = describe "steaming" $ do it "getEventList and getEventStream yields the same result" $ \(p, pool) -> do storedEvs <- for ([1 .. 10] :: [Int]) $ \i -> do @@ -257,7 +257,7 @@ streamingSpec = describe "steaming" $ do fmap storedEvent evStream `shouldBe` fmap storedEvent evList evStream `shouldBe` evList -queryEventsSpec :: SpecWith (PostgresEvent TestModel NoIndex TestEvent, Pool Connection) +queryEventsSpec :: SpecWith (PostgresEvent NoIndex TestModel TestEvent, Pool Connection) queryEventsSpec = describe "queryEvents" $ do it "Can query events" $ \(_p, pool) -> withResource pool $ \conn -> do evs <- queryEvents @TestEvent conn (getEventTableName eventTable) NoIndex @@ -289,7 +289,7 @@ queryEventsSpec = describe "queryEvents" $ do event_numbers `shouldSatisfy` (\n -> and $ zipWith (>) (drop 1 n) n) postHookSpec - :: TVar (Set UUID) -> SpecWith (PostgresEvent TestModel NoIndex TestEvent, Pool Connection) + :: TVar (Set UUID) -> SpecWith (PostgresEvent NoIndex TestModel TestEvent, Pool Connection) postHookSpec processedEvents = describe "updateHook" $ do it "Ensure we start with empty TVar" $ \_ -> do events <- readTVarIO processedEvents @@ -312,7 +312,7 @@ postHookSpec processedEvents = describe "updateHook" $ do m' <- getModel p NoIndex m' `shouldBe` 0 -migrationSpec :: SpecWith (PostgresEvent TestModel NoIndex TestEvent, Pool Connection) +migrationSpec :: SpecWith (PostgresEvent NoIndex TestModel TestEvent, Pool Connection) migrationSpec = describe "migrate1to1" $ do it "Keeps all events when using `id` to update" $ \(_p, pool) -> do evs <- withResource pool $ \conn -> @@ -371,14 +371,14 @@ migrationSpec = describe "migrate1to1" $ do brokenExists `shouldBe` False _ -> fail "Unexpectedly lacking table versions!" -migrationConcurrencySpec :: SpecWith (PostgresEvent TestModel NoIndex TestEvent, Pool Connection) +migrationConcurrencySpec :: SpecWith (PostgresEvent NoIndex TestModel TestEvent, Pool Connection) migrationConcurrencySpec = describe "Event table is locked during migration" $ do it "migrate1to1" $ \(m0, pool) -> migrationTest m0 pool mig1to1 it "migrate1toMany" $ \(m0, pool) -> migrationTest m0 pool mig1toMany it "migrate1toManyWithState" $ \(m0, pool) -> migrationTest m0 pool mig1toManyState where migrationTest - :: PostgresEvent TestModel NoIndex TestEvent + :: PostgresEvent NoIndex TestModel TestEvent -> Pool Connection -> EventMigration -> IO () @@ -427,7 +427,7 @@ migrationConcurrencySpec = describe "Event table is locked during migration" $ d threadDelay 250000 pure a -loggingSpec :: SpecWith (PostgresEvent TestModel NoIndex TestEvent, Pool Connection) +loggingSpec :: SpecWith (PostgresEvent NoIndex TestModel TestEvent, Pool Connection) loggingSpec = describe "Callstacks" $ do it "Callstack for runCmd reference this file" $ \(p', _) -> do (logVar, p) <- withStmLogger p' @@ -451,8 +451,8 @@ loggingSpec = describe "Callstacks" $ do let thisFile = "DomainDriven/Persistance/PostgresSpec.hs" logs `shouldSatisfy` all ((thisFile `L.isInfixOf`) . show) withStmLogger - :: PostgresEvent TestModel NoIndex TestEvent - -> IO (TVar [LogEntry], PostgresEvent TestModel NoIndex TestEvent) + :: PostgresEvent NoIndex TestModel TestEvent + -> IO (TVar [LogEntry], PostgresEvent NoIndex TestModel TestEvent) withStmLogger p = do logVar <- newTVarIO [] pure (logVar, p{logger = \s -> atomically $ modifyTVar logVar (s :)}) diff --git a/domaindriven-examples/domaindriven-examples.cabal b/domaindriven-examples/domaindriven-examples.cabal index 4aad180..e63a06f 100644 --- a/domaindriven-examples/domaindriven-examples.cabal +++ b/domaindriven-examples/domaindriven-examples.cabal @@ -61,7 +61,7 @@ executable hierarchical-example TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -Wall-missed-specialisations -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -threaded -rtsopts -with-rtsopts=-N build-depends: aeson , base @@ -113,7 +113,7 @@ executable simple-example TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -Wall-missed-specialisations -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -threaded -rtsopts -with-rtsopts=-N build-depends: aeson , base diff --git a/domaindriven-examples/package.yaml b/domaindriven-examples/package.yaml index 08096e9..aaca0c5 100644 --- a/domaindriven-examples/package.yaml +++ b/domaindriven-examples/package.yaml @@ -73,7 +73,6 @@ ghc-options: - -Wincomplete-record-updates - -Wincomplete-patterns - -Wunused-packages -- -Wall-missed-specialisations executables: simple-example: diff --git a/domaindriven/domaindriven.cabal b/domaindriven/domaindriven.cabal index a7850d4..995ad36 100644 --- a/domaindriven/domaindriven.cabal +++ b/domaindriven/domaindriven.cabal @@ -70,7 +70,7 @@ library TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -Wall-missed-specialisations + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages build-depends: aeson , base diff --git a/domaindriven/package.yaml b/domaindriven/package.yaml index 4e3b525..8c8974f 100644 --- a/domaindriven/package.yaml +++ b/domaindriven/package.yaml @@ -81,7 +81,6 @@ ghc-options: - -Wincomplete-record-updates - -Wincomplete-patterns - -Wunused-packages -- -Wall-missed-specialisations library: source-dirs: src From 35e9e549946c682a5953ce7851f4b2109f0636d5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Thu, 26 Jun 2025 16:37:19 +0200 Subject: [PATCH 12/50] export indexed handlers --- domaindriven/src/DomainDriven.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/domaindriven/src/DomainDriven.hs b/domaindriven/src/DomainDriven.hs index b80ca6d..c5063b1 100644 --- a/domaindriven/src/DomainDriven.hs +++ b/domaindriven/src/DomainDriven.hs @@ -15,10 +15,14 @@ import DomainDriven.Server.Api as X ( CbCmd , CbQuery , Cmd + , Query + , CbCmdI + , CbQueryI + , CmdI + , QueryI , Field (..) , JsonObject (..) , NamedField (..) - , Query ) import DomainDriven.Server.DomainDrivenApi as X ( ApiTagFromLabel (..) @@ -35,6 +39,10 @@ import DomainDriven.Server.Server as X , CbQueryServer (..) , CmdServer (..) , QueryServer (..) + , CbCmdServerI (..) + , CbQueryServerI (..) + , CmdServerI (..) + , QueryServerI (..) , ReadPersistence (..) , WritePersistence (..) ) From 3b564c9ed620fc8cd9a71984f054c840e1de6407 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Thu, 10 Jul 2025 09:34:45 +0200 Subject: [PATCH 13/50] Clean up and change resolver --- .../Persistance/Postgres/Internal.hs | 17 +---------------- .../Persistance/Postgres/Migration.hs | 6 +----- .../DomainDriven/Persistance/Postgres/Types.hs | 18 ++++++++++++++++++ domaindriven/src/DomainDriven/Server/Server.hs | 2 +- stack.yaml | 2 +- 5 files changed, 22 insertions(+), 23 deletions(-) diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs index 2fb095b..b57c06f 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs @@ -10,7 +10,7 @@ import Data.Generics.Labels () import Data.Generics.Product import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HM -import Data.Hashable (Hashable, hash) +import Data.Hashable (hash) import Data.IORef import Data.Int import Data.Maybe (fromMaybe) @@ -18,8 +18,6 @@ import Data.Pool.Introspection as Pool import Data.Sequence (Seq (..)) import Data.Sequence qualified as Seq import Data.String -import Data.Text (Text) -import Data.Text qualified as T import Data.Time import Database.PostgreSQL.Simple as PG import Database.PostgreSQL.Simple.Cursor qualified as Cursor @@ -47,19 +45,6 @@ data LogEntry | WaitForConnectionDuration NominalDiffTime OneLineCallStack deriving (Show, Generic) -class Hashable a => IsPgIndex a where - toPgIndex :: a -> Text -- FIXME: Should not be Text - fromPgIndex :: Text -> a - toQuery :: a -> Query - toQuery t = "'" <> (fromString . T.unpack . toPgIndex) t <> "'" - -instance IsPgIndex NoIndex where - toPgIndex = const "0" - fromPgIndex _ = NoIndex - -instance IsPgIndex Indexed where - toPgIndex (Indexed t) = t - fromPgIndex = Indexed newtype OneLineCallStack = OneLineCallStack CallStack diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Migration.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Migration.hs index 1f5f48b..aaec80a 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Migration.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Migration.hs @@ -8,11 +8,7 @@ import Data.Int import Data.String import Database.PostgreSQL.Simple as PG import DomainDriven.Persistance.Class -import DomainDriven.Persistance.Postgres.Internal - ( IsPgIndex (..) - , mkEventQuery - , mkEventStream - ) +import DomainDriven.Persistance.Postgres.Internal (mkEventQuery, mkEventStream) import DomainDriven.Persistance.Postgres.Types import Streamly.Data.Fold qualified as Fold import Streamly.Data.Stream.Prelude qualified as Stream diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Types.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Types.hs index aca1079..678eb2d 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Types.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Types.hs @@ -3,6 +3,8 @@ module DomainDriven.Persistance.Postgres.Types where import Control.Monad.Catch import Data.Aeson import Data.Int +import Data.Text qualified as T +import Data.String import Data.Pool.Introspection as Pool import Data.Time import Data.Typeable @@ -12,6 +14,8 @@ import Database.PostgreSQL.Simple qualified as PG import Database.PostgreSQL.Simple.FromField qualified as FF import DomainDriven.Persistance.Class import GHC.Generics (Generic) +import Data.Hashable (Hashable) +import Data.Text (Text) import Prelude data PersistanceError @@ -25,6 +29,20 @@ type EventTableName = String type PreviousEventTableName = String type ChunkSize = Int +class Hashable a => IsPgIndex a where + toPgIndex :: a -> Text -- FIXME: Should not be Text + fromPgIndex :: Text -> a + toQuery :: a -> PG.Query + toQuery t = "'" <> (fromString . T.unpack . toPgIndex) t <> "'" + +instance IsPgIndex NoIndex where + toPgIndex = const "0" + fromPgIndex _ = NoIndex + +instance IsPgIndex Indexed where + toPgIndex (Indexed t) = t + fromPgIndex = Indexed + type EventMigration = PreviousEventTableName -> EventTableName -> Connection -> IO () data EventTable diff --git a/domaindriven/src/DomainDriven/Server/Server.hs b/domaindriven/src/DomainDriven/Server/Server.hs index c8b539d..3fea7d9 100644 --- a/domaindriven/src/DomainDriven/Server/Server.hs +++ b/domaindriven/src/DomainDriven/Server/Server.hs @@ -60,7 +60,7 @@ data CbCmdServerI (index :: Type) (model :: Type) (event :: Type) m a = CbCmdI index ( ( forall n b - . MonadUnliftIO n + . (HasCallStack, MonadUnliftIO n) => RunCmd model event n b ) -> m a diff --git a/stack.yaml b/stack.yaml index d2a3b9d..9e47635 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2025-04-24 +resolver: nightly-2025-06-18 packages: - domaindriven-core - domaindriven From 41dcc509381582b34c403cafed03888d8faeaa2b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Wed, 27 Aug 2025 15:43:41 +0200 Subject: [PATCH 14/50] tmp, experimenting --- .claude/settings.local.json | 12 ++ domaindriven-effectful/ChangeLog.md | 5 + domaindriven-effectful/README.md | 128 ++++++++++++++++++ .../domaindriven-effectful.cabal | 91 +++++++++++++ domaindriven-effectful/package.yaml | 93 +++++++++++++ .../src/DomainDriven/Effectful.hs | 8 ++ .../src/DomainDriven/Effectful/Aggregate.hs | 23 ++++ .../Effectful/Interpreter/InMemory.hs | 7 + .../src/DomainDriven/Effectful/Projection.hs | 29 ++++ stack.yaml | 1 + 10 files changed, 397 insertions(+) create mode 100644 .claude/settings.local.json create mode 100644 domaindriven-effectful/ChangeLog.md create mode 100644 domaindriven-effectful/README.md create mode 100644 domaindriven-effectful/domaindriven-effectful.cabal create mode 100644 domaindriven-effectful/package.yaml create mode 100644 domaindriven-effectful/src/DomainDriven/Effectful.hs create mode 100644 domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs create mode 100644 domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs create mode 100644 domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs diff --git a/.claude/settings.local.json b/.claude/settings.local.json new file mode 100644 index 0000000..fd40819 --- /dev/null +++ b/.claude/settings.local.json @@ -0,0 +1,12 @@ +{ + "permissions": { + "allow": [ + "Bash(stack build)", + "Bash(stack test)", + "Bash(rg:*)", + "Bash(find:*)", + "Bash(grep:*)" + ], + "deny": [] + } +} \ No newline at end of file diff --git a/domaindriven-effectful/ChangeLog.md b/domaindriven-effectful/ChangeLog.md new file mode 100644 index 0000000..bbe5838 --- /dev/null +++ b/domaindriven-effectful/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for domaindriven + +## 0.5.0 + +First release published on hackage. diff --git a/domaindriven-effectful/README.md b/domaindriven-effectful/README.md new file mode 100644 index 0000000..2af6acc --- /dev/null +++ b/domaindriven-effectful/README.md @@ -0,0 +1,128 @@ +# DomainDriven + +DomainDriven is a batteries included synchronous event sourcing and CQRS library. The goal of this library is to allow you to implement DDD principles without focusing on the boilerplate. + +It uses `Template Haskell` we generate a Servant server from the specification and we aim to keep the specification as succinct as we can. + +## The idea + +- Use a GADT to specify the actions, what will be translated into `GET`s and `POST`s. +- Make each event update run in a transaction, thereby avoiding the eventual consistency issues commonly associated with event sourcing. + +## How it works + +In order to implement a model in `domaindriven` you have to define: +- The model (current state) +- The events +- How to update the model when new events come in +- The actions (queries and commands) +- How to handle actions + +### Model + +The model is the current state of the system. This is what you normally would keep in a database, but as this is an event sourced system the state is not fundamental as it can be recalculated. + +Currently all implemented persistence strategies all keep the state in memory. + +### Events + +Events are things that happened in the past. The event you define represent all the changes that can occur in the system. + +Events should be specified in past tens. +```haskell + +data Event + = IncreasedCounter + | DecreasedCounter +``` + +### Event handler + +The model is calculated as a fold over the stream of events. As events happened in the past we can never refuse to handle them. This means the event handler is simply: + +``` haskell +applyEvent :: Model -> Stored Event -> Model +``` + +where Stored is defined as: +``` haskell +data Stored a = Stored + { storedEvent :: a + , storedTimestamp :: UTCTime + , storedUUID :: UUID + } +``` + +### Commands + +Commands are defined using a GADT with one type parameter representing the return type. For example: + +``` haskell +-- Same as: data StorageAction (x :: ParamPart) method a where +data StorageAction :: Action where + GetFile + :: P x "fileId" UUID + -> StorageAction x Query ByteString + AddFile + :: P x "fileContent" ByteString + -> StorageAction Cmd UUID + RemoveFile + :: P x "fileId" UUID + -> StorageAction Cmd () +``` + +### Action handler + +Actions, in contrast to events, are allowed to fail. If an action succeeds we need to return a value of the type specified by the constructor and, if it was a command, a list of events. The action handler do not update the state. + +In addition you may need to make requests, read from disk, or perform other side effects in order to calculate the result. + +`ActionHandler` is defined as: + +``` haskell +type ActionHandler model event m c = + forall method a. c 'ParamType method a -> HandlerType method model event m a +``` + +In practice this means you specify actions as + +```haskell + +data CounterAction x method return where + GetCounter ::CounterAction x Query Int + IncreaseCounter ::CounterAction x Cmd Int + DecreaseCounter ::CounterAction x Cmd Int +``` + +and the corresponding handler as + +```haskell +handleAction :: ActionHandler CounterAction CounterEvent IO a +handleAction = \case + GetCounter -> Query $ pure -- Query is just `model -> IO a` + IncreaseCounter -> Cmd $ \_ -> `model -> IO (model -> a, [CounterEvent])` + pure (id -- return state as is, after the event is applied + , [CounterIncreased]) + DecreaseCounter -> Cmd $ \counter -> do + when (counter < 1) (throwM NegativeNotSupported) + pure (id, [CounterDecreased]) +``` + +A `Query` takes a `model -> m a`, i.e. you get access to the model and the ability to run monadic efficts. `Query`s will be translates into `GET` in the generated API. + +A `Cmd` has the additional ability of emitting events. It takes a `model -> m (model -> a, [event])`. The return value is specified as a function from the updated model to the return type. This way we can, in the Counter example, return the new value after the event handler has run. + + +### Generating the server + + +Now we have defined the core parts of our service. We can now generate the server using the template-haskell function `mkServer`. It takes two arguments: The server config and the name of the GADT representing the actions. E.g. `$(mkServer counterActionConfig ''CounterAction)`. + +The `ServerConfig`, `storeActionConfig` in this example, contains the API options for the for the Action and all it's sub actions, as well as a all parameter names. This can be tenerated with `$(mkServerConfig "counterActionConfig")`, but due to TemplateHaskell's stage restrictions it cannot run in the same file as `mkServer`. + + +### Simple example + +Minimal example can be found in [examples/simple/Main.hs](examples/simple/Main.hs), this uses the model defined in [models/Models/Counter.hs](models/Models/Counter.hs) + + diff --git a/domaindriven-effectful/domaindriven-effectful.cabal b/domaindriven-effectful/domaindriven-effectful.cabal new file mode 100644 index 0000000..21023be --- /dev/null +++ b/domaindriven-effectful/domaindriven-effectful.cabal @@ -0,0 +1,91 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.38.1. +-- +-- see: https://github.com/sol/hpack + +name: domaindriven-effectful +version: 0.5.0 +synopsis: Batteries included event sourcing and CQRS +description: Please see the README on GitHub at +category: Web +homepage: https://github.com/tommyengstrom/domaindriven#readme +bug-reports: https://github.com/tommyengstrom/domaindriven/issues +author: Tommy Engström +maintainer: tommy@tommyengstrom.com +copyright: 2023 Tommy Engström +license: BSD3 +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/tommyengstrom/domaindriven + +library + exposed-modules: + DomainDriven.Effectful + DomainDriven.Effectful.Aggregate + DomainDriven.Effectful.Interpreter.InMemory + DomainDriven.Effectful.Projection + other-modules: + Paths_domaindriven_effectful + hs-source-dirs: + src + default-extensions: + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedLabels + OverloadedStrings + PolyKinds + RankNTypes + ScopedTypeVariables + StandaloneDeriving + StrictData + TupleSections + TypeApplications + TypeFamilyDependencies + TypeOperators + TypeSynonymInstances + ViewPatterns + ghc-options: -Weverything -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wno-unused-packages + build-depends: + aeson + , base + , bytestring + , domaindriven-core + , effectful + , effectful-th + , exceptions + , generics-sop + , mtl + , openapi3 + , optics + , servant + , servant-auth-server + , servant-client-core + , servant-openapi3 + , servant-server + , text + , unliftio + , uuid + default-language: Haskell2010 diff --git a/domaindriven-effectful/package.yaml b/domaindriven-effectful/package.yaml new file mode 100644 index 0000000..73e83e7 --- /dev/null +++ b/domaindriven-effectful/package.yaml @@ -0,0 +1,93 @@ +name: domaindriven-effectful +version: 0.5.0 +github: "tommyengstrom/domaindriven" +license: BSD3 +author: "Tommy Engström" +maintainer: "tommy@tommyengstrom.com" +copyright: "2023 Tommy Engström" + +extra-source-files: +- README.md +- ChangeLog.md + +# Metadata used when publishing your package +synopsis: Batteries included event sourcing and CQRS +category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: +- base +- effectful +- effectful-th +- aeson +- domaindriven-core +- exceptions +- generics-sop +- openapi3 +- optics +- servant +- servant-auth-server +- servant-client-core +- servant-openapi3 +- servant-server +- text + + +default-extensions: +- ConstraintKinds +- DataKinds +- DeriveAnyClass +- DeriveFunctor +- DeriveGeneric +- DeriveTraversable +- DerivingStrategies +- DuplicateRecordFields +- FlexibleContexts +- FlexibleInstances +- FunctionalDependencies +- GADTs +- GeneralizedNewtypeDeriving +- ImportQualifiedPost +- LambdaCase +- MultiParamTypeClasses +- MultiWayIf +- NamedFieldPuns +- NoImplicitPrelude +- OverloadedLabels +- OverloadedStrings +- PolyKinds +- RankNTypes +- ScopedTypeVariables +- StandaloneDeriving +- StrictData +- TupleSections +- TypeApplications +- TypeFamilyDependencies +- TypeOperators +- TypeSynonymInstances +- ViewPatterns + +ghc-options: +- -Weverything +- -Werror +- -Wcompat +- -Widentities +- -Wincomplete-record-updates +- -Wincomplete-uni-patterns +- -Wpartial-fields +- -Wredundant-constraints +- -Wincomplete-record-updates +- -Wincomplete-patterns +- -Wno-unused-packages + +library: + source-dirs: src + dependencies: + - bytestring + - mtl + - unliftio + - uuid diff --git a/domaindriven-effectful/src/DomainDriven/Effectful.hs b/domaindriven-effectful/src/DomainDriven/Effectful.hs new file mode 100644 index 0000000..d351056 --- /dev/null +++ b/domaindriven-effectful/src/DomainDriven/Effectful.hs @@ -0,0 +1,8 @@ +module DomainDriven.Effectful + ( module X + ) +where + +import DomainDriven.Effectful.Aggregate as X +import DomainDriven.Effectful.Projection as X + diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs new file mode 100644 index 0000000..b163cb9 --- /dev/null +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module DomainDriven.Effectful.Aggregate where + +import Effectful +import Effectful.Dispatch.Dynamic + +data Aggregate model event index :: Effect where + RunTransaction + :: index + -> (model -> Eff es (model -> a, [event])) + -> Aggregate model event index (Eff es) a + +type instance DispatchOf (Aggregate model event index) = 'Dynamic + +-- | Run a synchronous transaction while holding a lock on the aggregate +runTransaction + :: forall model event index es a + . Aggregate model event index :> es + => index + -> (model -> Eff es (model -> a, [event])) + -> Eff es a +runTransaction idx cmd = send (RunTransaction idx cmd) diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs new file mode 100644 index 0000000..e2dbe49 --- /dev/null +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs @@ -0,0 +1,7 @@ +module DomainDriven.Effectful.Interpreter.InMemory where + +import DomainDriven.Effectful.Aggregate +import DomainDriven.Effectful.Projection +import Effectful + + diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs new file mode 100644 index 0000000..0a30039 --- /dev/null +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module DomainDriven.Effectful.Projection where + +import Effectful +import Effectful.Dispatch.Dynamic +import DomainDriven.Persistance.Class (Stored) + +data Projection model event index :: Effect where + GetModel :: Projection model event index m model + GetEventList ::Projection model event index m [Stored event] + +type instance DispatchOf (Projection model event index) = 'Dynamic + +-- | Get the model +getModel + :: forall model event index es + . Projection model event index :> es + => Eff es model +getModel = send (GetModel @model @event @index) + + +-- | Get a list of all the events used to create the model +getEventList + :: forall model event index es + . Projection model event index :> es + => Eff es [Stored event] +getEventList = send (GetEventList @model @event @index) + diff --git a/stack.yaml b/stack.yaml index 9e47635..4a0f221 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,7 @@ resolver: nightly-2025-06-18 packages: - domaindriven-core +- domaindriven-effectful - domaindriven - domaindriven-examples From 3cfe68c4455889f0e1c6497ad896baf10064317b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Tue, 2 Sep 2025 21:48:00 +0200 Subject: [PATCH 15/50] prototyping --- .claude/settings.local.json | 7 +- CLAUDE.md | 58 ++++++ README.md | 6 + domaindriven-effectful-examples/README.md | 37 ++++ .../domaindriven-effectful-examples.cabal | 178 ++++++++++++++++++ .../hierarchical/Main.hs | 158 ++++++++++++++++ domaindriven-effectful-examples/package.yaml | 115 +++++++++++ .../simple-with-helpers/Main.hs | 97 ++++++++++ .../simple/Main.hs | 92 +++++++++ domaindriven-effectful/IMPLEMENTATION.md | 81 ++++++++ .../domaindriven-effectful.cabal | 68 +++++-- domaindriven-effectful/package.yaml | 35 ++-- .../src/DomainDriven/Effectful.hs | 1 + .../src/DomainDriven/Effectful/Helpers.hs | 63 +++++++ .../Effectful/Interpreter/InMemory.hs | 41 ++++ domaindriven-effectful/test/Spec.hs | 132 +++++++++++++ specs/effectful.md | 18 ++ stack.yaml | 1 + 18 files changed, 1152 insertions(+), 36 deletions(-) create mode 100644 CLAUDE.md create mode 100644 domaindriven-effectful-examples/README.md create mode 100644 domaindriven-effectful-examples/domaindriven-effectful-examples.cabal create mode 100644 domaindriven-effectful-examples/hierarchical/Main.hs create mode 100644 domaindriven-effectful-examples/package.yaml create mode 100644 domaindriven-effectful-examples/simple-with-helpers/Main.hs create mode 100644 domaindriven-effectful-examples/simple/Main.hs create mode 100644 domaindriven-effectful/IMPLEMENTATION.md create mode 100644 domaindriven-effectful/src/DomainDriven/Effectful/Helpers.hs create mode 100644 domaindriven-effectful/test/Spec.hs create mode 100644 specs/effectful.md diff --git a/.claude/settings.local.json b/.claude/settings.local.json index fd40819..9e29f3e 100644 --- a/.claude/settings.local.json +++ b/.claude/settings.local.json @@ -5,7 +5,12 @@ "Bash(stack test)", "Bash(rg:*)", "Bash(find:*)", - "Bash(grep:*)" + "Bash(grep:*)", + "Bash(stack test:*)", + "WebFetch(domain:hackage.haskell.org)", + "WebFetch(domain:hackage-content.haskell.org)", + "WebFetch(domain:github.com)", + "Bash(stack build:*)" ], "deny": [] } diff --git a/CLAUDE.md b/CLAUDE.md new file mode 100644 index 0000000..5dd7d85 --- /dev/null +++ b/CLAUDE.md @@ -0,0 +1,58 @@ +# CLAUDE.md + +This file provides guidance to Claude Code (claude.ai/code) when working with code in this repository. + +## Build Commands + +- **Build all packages**: `stack build` +- **Build specific package**: `stack build domaindriven-effectful` +- **Run tests**: `stack test` +- **Run specific test**: `stack test domaindriven-effectful` +- **Clean build**: `stack clean` + +## Architecture Overview + +DomainDriven is a synchronous event sourcing and CQRS library split into multiple packages: + +### Core Components + +- **domaindriven-core**: Core persistence model with PostgreSQL and in-memory backends + - `ReadModel`/`WriteModel` type classes define the persistence interface + - `ForgetfulInMemory`: In-memory backend for testing/development + - `Postgres`: Production persistence with transactional guarantees + - Synchronous event sourcing with locks to avoid eventual consistency issues + +- **domaindriven**: Main library using GADTs and Template Haskell for API generation + - Custom Servant combinators (`Cmd`, `Query`, `CbCmd`, `CbQuery`) + - `DomainDrivenApi` wrapper for automatic route generation + - Server interpreters that connect to persistence backends + +- **domaindriven-effectful**: Experimental Effectful-based implementation + - Uses standard Servant combinators instead of custom ones + - Two main effects: `Aggregate` (commands) and `Projection` (queries) + - Dynamic dispatch interpreters for different backends + - Located in `domaindriven-effectful/` + +### Key Design Patterns + +1. **Event Sourcing Model**: + - Model = current state (derived from events) + - Events = immutable history of changes + - `applyEvent :: Model -> Stored Event -> Model` + +2. **Command/Query Separation**: + - Commands emit events and may update state + - Queries are read-only operations + - Both can be composed hierarchically + +3. **Index Types**: + - `NoIndex` for single aggregates + - Custom index types for multiple aggregates + - Functional dependencies can reduce type parameters + +## Development Notes + +- All packages use extensive language extensions (see package.yaml files) +- Strict warning settings (`-Wall -Werror`) - fix all warnings before committing +- The Effectful prototype aims to simplify the API while maintaining type safety +- Tests use `hspec` framework with in-memory backends \ No newline at end of file diff --git a/README.md b/README.md index 20ec261..c46bba3 100644 --- a/README.md +++ b/README.md @@ -4,5 +4,11 @@ DomainDriven is a batteries included synchronous event sourcing and CQRS library - [domaindriven-core](domaindriven-core) Contains the core persistance model as well as postgres and in-memory backend. - [domaindriven](domaindriven) Introduces a convenient way of specifying actions using GADTs and TemplateHaskell. +- [domaindriven](domaindriven-examples) Examples of how to use domaindriven. + + +## Design idea + +The core idea it to do synchronous event sourcing with locks and thereby provide the upsides of event sourcing without the extra complexity introduced by asynchrnous workflows. diff --git a/domaindriven-effectful-examples/README.md b/domaindriven-effectful-examples/README.md new file mode 100644 index 0000000..06f0566 --- /dev/null +++ b/domaindriven-effectful-examples/README.md @@ -0,0 +1,37 @@ +# DomainDriven Effectful Examples + +Example applications demonstrating the Effectful-based domaindriven library. + +## Examples + +### Simple Counter +Basic counter application using Effectful effects with standard Servant API. + +Run with: +```bash +stack run simple +``` + +### Simple with Helpers +Counter application using simplified helper functions to reduce boilerplate. + +Run with: +```bash +stack run simple-with-helpers +``` + +### Hierarchical +Complex example with hierarchical models and sub-model composition. + +Run with: +```bash +stack run hierarchical +``` + +## Features Demonstrated + +- Using standard Servant combinators (`Get`, `Post`) instead of custom ones +- Effectful effects for domain logic +- In-memory persistence backend +- Type-safe effect composition +- Helper functions for common patterns \ No newline at end of file diff --git a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal new file mode 100644 index 0000000..a24c37c --- /dev/null +++ b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal @@ -0,0 +1,178 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.38.1. +-- +-- see: https://github.com/sol/hpack + +name: domaindriven-effectful-examples +version: 0.5.0 +synopsis: Examples for domaindriven-effectful +description: Examples demonstrating the Effectful-based domaindriven library +category: Web +homepage: https://github.com/tommyengstrom/domaindriven#readme +bug-reports: https://github.com/tommyengstrom/domaindriven/issues +author: Tommy Engström +maintainer: tommy@tommyengstrom.com +copyright: 2023 Tommy Engström +license: BSD3 +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/tommyengstrom/domaindriven + +executable hierarchical + main-is: Main.hs + other-modules: + Paths_domaindriven_effectful_examples + hs-source-dirs: + hierarchical + default-extensions: + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedLabels + OverloadedStrings + PolyKinds + RankNTypes + ScopedTypeVariables + StandaloneDeriving + StrictData + TupleSections + TypeApplications + TypeFamilyDependencies + TypeOperators + TypeSynonymInstances + ViewPatterns + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wno-unused-packages -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base + , domaindriven-core + , domaindriven-effectful + , effectful + , microlens + , servant + , servant-server + , warp + default-language: Haskell2010 + +executable simple + main-is: Main.hs + other-modules: + Paths_domaindriven_effectful_examples + hs-source-dirs: + simple + default-extensions: + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedLabels + OverloadedStrings + PolyKinds + RankNTypes + ScopedTypeVariables + StandaloneDeriving + StrictData + TupleSections + TypeApplications + TypeFamilyDependencies + TypeOperators + TypeSynonymInstances + ViewPatterns + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wno-unused-packages -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base + , domaindriven-core + , domaindriven-effectful + , effectful + , servant + , servant-server + , warp + default-language: Haskell2010 + +executable simple-with-helpers + main-is: Main.hs + other-modules: + Paths_domaindriven_effectful_examples + hs-source-dirs: + simple-with-helpers + default-extensions: + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedLabels + OverloadedStrings + PolyKinds + RankNTypes + ScopedTypeVariables + StandaloneDeriving + StrictData + TupleSections + TypeApplications + TypeFamilyDependencies + TypeOperators + TypeSynonymInstances + ViewPatterns + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wno-unused-packages -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base + , domaindriven-core + , domaindriven-effectful + , effectful + , servant + , servant-server + , warp + default-language: Haskell2010 diff --git a/domaindriven-effectful-examples/hierarchical/Main.hs b/domaindriven-effectful-examples/hierarchical/Main.hs new file mode 100644 index 0000000..157158c --- /dev/null +++ b/domaindriven-effectful-examples/hierarchical/Main.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedLabels #-} + +module Main where + +import Data.Aeson +import DomainDriven.Persistance.Class (Stored(..), NoIndex(..)) +import DomainDriven.Persistance.ForgetfulInMemory (createForgetful, ForgetfulInMemory) +import DomainDriven.Effectful +import DomainDriven.Effectful.Interpreter.InMemory +import Effectful +import Lens.Micro +import Network.Wai.Handler.Warp (run) +import Servant +import Servant.API.Generic +import Servant.Server.Generic (genericServeT, AsServerT) +import Prelude + +-------------------------------------------------------------------------------- +-- 1. Define the model +-------------------------------------------------------------------------------- + +-- | This does nothing interesting, only carries the sub-models. +data FullModel = FullModel + { numberModel :: NumberModel + , textModel :: TextModel + } + deriving (Show, Eq, Generic) + +newtype NumberModel = NumberModel {numberValue :: Int} + deriving (Show, Eq, Generic) + +newtype TextModel = TextModel {textValue :: String} + deriving (Show, Eq, Generic) + +-------------------------------------------------------------------------------- +-- 2. Define events and how to apply them +-------------------------------------------------------------------------------- +data FullEvent + = NumberEvent NumberEvent + | TextEvent TextEvent + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +data NumberEvent + = SetNumber Int + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +data TextEvent + = SetText String + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +applyEvent :: FullModel -> Stored FullEvent -> FullModel +applyEvent m (Stored ev _ _) = case ev of + NumberEvent ev' -> m & #numberModel %~ (`applyNumberEvent` ev') + TextEvent ev' -> m & #textModel %~ (`applyTextEvent` ev') + +applyNumberEvent :: NumberModel -> NumberEvent -> NumberModel +applyNumberEvent _ ev = case ev of + SetNumber i -> NumberModel i + +applyTextEvent :: TextModel -> TextEvent -> TextModel +applyTextEvent _ ev = case ev of + SetText t -> TextModel t + +-------------------------------------------------------------------------------- +-- 3. Define the API using record-based approach with standard Servant combinators +-------------------------------------------------------------------------------- + +data NumberAPI mode = NumberAPI + { getNumber :: mode Servant.:- Get '[JSON] Int + , setNumber :: mode Servant.:- ReqBody '[JSON] Int Servant.:> Post '[JSON] Int + } deriving (Generic) + +data TextAPI mode = TextAPI + { getText :: mode Servant.:- Get '[JSON] String + , setText :: mode Servant.:- ReqBody '[JSON] String Servant.:> Post '[JSON] String + } deriving (Generic) + +data FullAPI mode = FullAPI + { number :: mode Servant.:- "number" Servant.:> NamedRoutes NumberAPI + , text :: mode Servant.:- "text" Servant.:> NamedRoutes TextAPI + } deriving (Generic) + +-------------------------------------------------------------------------------- +-- 4. Implement handlers using Effectful effects +-------------------------------------------------------------------------------- + +-- Number handlers that work with the full model +numberHandlers + :: ( Projection FullModel FullEvent NoIndex Effectful.:> es + , Aggregate FullModel FullEvent NoIndex Effectful.:> es + ) + => NumberAPI (AsServerT (Eff es)) +numberHandlers = NumberAPI + { getNumber = do + model <- getModel @FullModel @FullEvent @NoIndex + pure $ numberValue (numberModel model) + , setNumber = \n -> runTransaction @FullModel @FullEvent @NoIndex NoIndex $ \_ -> + pure (\m -> numberValue (numberModel m), [NumberEvent (SetNumber n)]) + } + +-- Text handlers that work with the full model +textHandlers + :: ( Projection FullModel FullEvent NoIndex Effectful.:> es + , Aggregate FullModel FullEvent NoIndex Effectful.:> es + ) + => TextAPI (AsServerT (Eff es)) +textHandlers = TextAPI + { getText = do + model <- getModel @FullModel @FullEvent @NoIndex + pure $ textValue (textModel model) + , setText = \t -> runTransaction @FullModel @FullEvent @NoIndex NoIndex $ \_ -> + pure (\m -> textValue (textModel m), [TextEvent (SetText t)]) + } + +-- Full API handlers combining number and text +fullHandlers + :: ( Projection FullModel FullEvent NoIndex Effectful.:> es + , Aggregate FullModel FullEvent NoIndex Effectful.:> es + ) + => FullAPI (AsServerT (Eff es)) +fullHandlers = FullAPI + { number = numberHandlers + , text = textHandlers + } + +-------------------------------------------------------------------------------- +-- 5. Wire up the server with effect interpreters +-------------------------------------------------------------------------------- + +mkFullServer :: ForgetfulInMemory FullModel NoIndex FullEvent -> Application +mkFullServer backend = + genericServeT runEffects fullHandlers + where + -- Helper to run effects + runEffects :: Eff '[Projection FullModel FullEvent NoIndex, + Aggregate FullModel FullEvent NoIndex, + IOE] a -> Handler a + runEffects = liftIO . runEff . runAggregateInMemory backend . runProjectionInMemory backend NoIndex + +main :: IO () +main = do + let port = 7878 + putStrLn $ "Running Effectful hierarchical example on port " <> show port + + -- Initialize with default values + let initialModel = FullModel (NumberModel 0) (TextModel "") + backend <- createForgetful @NoIndex applyEvent initialModel + + -- Create and run the application + let app = mkFullServer backend + + run port app \ No newline at end of file diff --git a/domaindriven-effectful-examples/package.yaml b/domaindriven-effectful-examples/package.yaml new file mode 100644 index 0000000..d32eb0d --- /dev/null +++ b/domaindriven-effectful-examples/package.yaml @@ -0,0 +1,115 @@ +name: domaindriven-effectful-examples +version: 0.5.0 +github: "tommyengstrom/domaindriven" +license: BSD3 +author: "Tommy Engström" +maintainer: "tommy@tommyengstrom.com" +copyright: "2023 Tommy Engström" + +extra-source-files: +- README.md + +# Metadata used when publishing your package +synopsis: Examples for domaindriven-effectful +category: Web + +description: Examples demonstrating the Effectful-based domaindriven library + +dependencies: +- base + +default-extensions: +- ConstraintKinds +- DataKinds +- DeriveAnyClass +- DeriveFunctor +- DeriveGeneric +- DeriveTraversable +- DerivingStrategies +- DuplicateRecordFields +- FlexibleContexts +- FlexibleInstances +- FunctionalDependencies +- GADTs +- GeneralizedNewtypeDeriving +- ImportQualifiedPost +- LambdaCase +- MultiParamTypeClasses +- MultiWayIf +- NamedFieldPuns +- NoImplicitPrelude +- OverloadedLabels +- OverloadedStrings +- PolyKinds +- RankNTypes +- ScopedTypeVariables +- StandaloneDeriving +- StrictData +- TupleSections +- TypeApplications +- TypeFamilyDependencies +- TypeOperators +- TypeSynonymInstances +- ViewPatterns + +ghc-options: +- -Wall +- -Werror +- -Wcompat +- -Widentities +- -Wincomplete-record-updates +- -Wincomplete-uni-patterns +- -Wpartial-fields +- -Wredundant-constraints +- -Wincomplete-patterns +- -Wno-unused-packages + +executables: + simple: + main: Main.hs + source-dirs: simple + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - aeson + - domaindriven-core + - domaindriven-effectful + - effectful + - servant + - servant-server + - warp + + simple-with-helpers: + main: Main.hs + source-dirs: simple-with-helpers + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - aeson + - domaindriven-core + - domaindriven-effectful + - effectful + - servant + - servant-server + - warp + + hierarchical: + main: Main.hs + source-dirs: hierarchical + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - aeson + - domaindriven-core + - domaindriven-effectful + - effectful + - microlens + - servant + - servant-server + - warp \ No newline at end of file diff --git a/domaindriven-effectful-examples/simple-with-helpers/Main.hs b/domaindriven-effectful-examples/simple-with-helpers/Main.hs new file mode 100644 index 0000000..3e75789 --- /dev/null +++ b/domaindriven-effectful-examples/simple-with-helpers/Main.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Main where + +import Data.Aeson +import DomainDriven.Persistance.Class (Stored(..), NoIndex(..)) +import DomainDriven.Persistance.ForgetfulInMemory (createForgetful, ForgetfulInMemory) +import DomainDriven.Effectful +import DomainDriven.Effectful.Interpreter.InMemory +import Effectful +import Network.Wai.Handler.Warp (run) +import Servant +import Servant.API.Generic +import Servant.Server.Generic (genericServeT, AsServerT) +import Prelude + +-------------------------------------------------------------------------------- +-- 1. Define the model +-------------------------------------------------------------------------------- +newtype CounterModel = CounterModel {getCounter :: Int} + deriving (Show, Eq, Generic) + +-------------------------------------------------------------------------------- +-- 2. Define events and how to apply them +-------------------------------------------------------------------------------- +data CounterEvent + = Increase + | Decrease + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +applyEvent :: CounterModel -> Stored CounterEvent -> CounterModel +applyEvent (CounterModel i) (Stored ev _ _) = CounterModel $ case ev of + Increase -> i + 1 + Decrease -> i - 1 + +-- Define the EventSourced instance to use helpers +instance EventSourced CounterModel CounterEvent NoIndex + +-------------------------------------------------------------------------------- +-- 3. Define the API using record-based approach with standard Servant combinators +-------------------------------------------------------------------------------- +data CounterAPI mode = CounterAPI + { current :: mode Servant.:- Get '[JSON] Int + , increase :: mode Servant.:- Post '[JSON] Int + , decrease :: mode Servant.:- Post '[JSON] Int + , safeDecrease :: mode Servant.:- "safe-decrease" Servant.:> Post '[JSON] (Maybe Int) + } deriving (Generic) + +-------------------------------------------------------------------------------- +-- 4. Implement the server handlers using simplified helpers +-------------------------------------------------------------------------------- + +-- | Counter handlers using simplified helper functions +counterHandlers + :: ( Projection CounterModel CounterEvent NoIndex Effectful.:> es + , Aggregate CounterModel CounterEvent NoIndex Effectful.:> es + ) + => CounterAPI (AsServerT (Eff es)) +counterHandlers = CounterAPI + { current = getCounter <$> queryModel @CounterModel @CounterEvent + , increase = simpleCommand @CounterModel @CounterEvent getCounter [Increase] + , decrease = simpleCommand @CounterModel @CounterEvent getCounter [Decrease] + , safeDecrease = conditionalCommand @CounterModel @CounterEvent + (\(CounterModel n) -> if n > 0 then Just [Decrease] else Nothing) + getCounter + } + +-------------------------------------------------------------------------------- +-- 5. Wire up the server with effect interpreters +-------------------------------------------------------------------------------- + +mkCounterServer :: ForgetfulInMemory CounterModel NoIndex CounterEvent -> Application +mkCounterServer backend = + genericServeT runEffects counterHandlers + where + runEffects :: Eff '[Projection CounterModel CounterEvent NoIndex, + Aggregate CounterModel CounterEvent NoIndex, + IOE] a -> Handler a + runEffects = liftIO . runEff . runAggregateInMemory backend . runProjectionInMemory backend NoIndex + +main :: IO () +main = do + let port = 7878 + putStrLn $ "Running Effectful counter with helpers on port " <> show port + + -- Initialize the in-memory backend + backend <- createForgetful @NoIndex applyEvent (CounterModel 0) + + -- Create and run the application + let app = mkCounterServer backend + + run port app \ No newline at end of file diff --git a/domaindriven-effectful-examples/simple/Main.hs b/domaindriven-effectful-examples/simple/Main.hs new file mode 100644 index 0000000..f8d1844 --- /dev/null +++ b/domaindriven-effectful-examples/simple/Main.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Main where + +import Data.Aeson +import DomainDriven.Persistance.Class (Stored(..), NoIndex(..)) +import DomainDriven.Persistance.ForgetfulInMemory (createForgetful, ForgetfulInMemory) +import DomainDriven.Effectful +import DomainDriven.Effectful.Interpreter.InMemory +import Effectful +import Network.Wai.Handler.Warp (run) +import Servant +import Servant.API.Generic +import Servant.Server.Generic (genericServeT, AsServerT) +import Prelude + +-------------------------------------------------------------------------------- +-- 1. Define the model +-------------------------------------------------------------------------------- +newtype CounterModel = CounterModel {getCounter :: Int} + deriving (Show, Eq, Generic) + +-------------------------------------------------------------------------------- +-- 2. Define events and how to apply them +-------------------------------------------------------------------------------- +data CounterEvent + = Increase + | Decrease + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +applyEvent :: CounterModel -> Stored CounterEvent -> CounterModel +applyEvent (CounterModel i) (Stored ev _ _) = CounterModel $ case ev of + Increase -> i + 1 + Decrease -> i - 1 + +-------------------------------------------------------------------------------- +-- 3. Define the API using record-based approach with standard Servant combinators +-------------------------------------------------------------------------------- +data CounterAPI mode = CounterAPI + { current :: mode Servant.:- Get '[JSON] Int + , increase :: mode Servant.:- Post '[JSON] Int + , decrease :: mode Servant.:- Post '[JSON] Int + } deriving (Generic) + +-------------------------------------------------------------------------------- +-- 4. Implement the server handlers using Effectful effects +-------------------------------------------------------------------------------- + +-- | Counter handlers using Effectful effects +counterHandlers + :: ( Projection CounterModel CounterEvent NoIndex Effectful.:> es + , Aggregate CounterModel CounterEvent NoIndex Effectful.:> es + ) + => CounterAPI (AsServerT (Eff es)) +counterHandlers = CounterAPI + { current = getCounter <$> getModel @CounterModel @CounterEvent @NoIndex + , increase = runTransaction @CounterModel @CounterEvent @NoIndex NoIndex $ \_ -> + pure (getCounter, [Increase]) + , decrease = runTransaction @CounterModel @CounterEvent @NoIndex NoIndex $ \_ -> + pure (getCounter, [Decrease]) + } + +-------------------------------------------------------------------------------- +-- 5. Wire up the server with effect interpreters +-------------------------------------------------------------------------------- + +-- | Create the counter server with effect interpreters +mkCounterServer :: ForgetfulInMemory CounterModel NoIndex CounterEvent -> Application +mkCounterServer backend = + genericServeT runEffects counterHandlers + where + -- Helper to run effects and convert to Handler + runEffects :: Eff '[Projection CounterModel CounterEvent NoIndex, + Aggregate CounterModel CounterEvent NoIndex, + IOE] a -> Handler a + runEffects = liftIO . runEff . runAggregateInMemory backend . runProjectionInMemory backend NoIndex + +main :: IO () +main = do + let port = 7878 + putStrLn $ "Running Effectful counter on port " <> show port + + -- Initialize the in-memory backend + backend <- createForgetful @NoIndex applyEvent (CounterModel 0) + + -- Create and run the application + let app = mkCounterServer backend + + run port app \ No newline at end of file diff --git a/domaindriven-effectful/IMPLEMENTATION.md b/domaindriven-effectful/IMPLEMENTATION.md new file mode 100644 index 0000000..8eef587 --- /dev/null +++ b/domaindriven-effectful/IMPLEMENTATION.md @@ -0,0 +1,81 @@ +# DomainDriven Effectful Implementation + +This is a prototype implementation of domaindriven using the Effectful library instead of custom Servant combinators. + +## Key Changes from Original + +### 1. Standard Servant Combinators +- Uses `Get`, `Post` instead of custom `Query`, `Cmd` combinators +- Cleaner separation between HTTP layer and domain logic + +### 2. Effect-based Architecture +Two main effects: +- `Projection`: Read-only queries +- `Aggregate`: Transactional commands with event emission + +### 3. Interpreters +- `runProjectionInMemory`: Connects Projection effect to ForgetfulInMemory backend +- `runAggregateInMemory`: Handles transactional updates with locking + +## Implementation Status + +✅ **Completed:** +- Core effects (Aggregate, Projection) +- In-memory interpreters +- Simple counter example +- Hierarchical model example +- Type parameter helpers +- Basic test suite + +## Type Parameter Simplification + +The current implementation uses 3 type parameters for effects: +```haskell +Aggregate model event index +Projection model event index +``` + +### Potential Improvements: + +1. **Type Families Approach:** +```haskell +class EventSourced model where + type Event model + type Index model +``` + +2. **Functional Dependencies:** +```haskell +class EventSourced model event index | model -> event index +``` + +3. **Helper functions** (implemented): +- `withAggregate` for NoIndex aggregates +- `queryModel` for simple projections +- `simpleCommand` for basic commands + +## Examples + +### Simple Counter +Shows basic usage with NoIndex aggregates and standard Servant API. + +### Hierarchical Model +Demonstrates composition with sub-models and complex event hierarchies. + +### With Helpers +Uses simplified API with helper functions for common patterns. + +## Testing + +Run tests with: +```bash +stack test domaindriven-effectful +``` + +## Next Steps + +1. **Postgres Interpreter**: Implement `runAggregatePostgres` and `runProjectionPostgres` +2. **Performance Benchmarks**: Compare with original implementation +3. **Migration Guide**: Document path from GADT-based to Effectful approach +4. **Error Handling**: Add proper error effects and validation +5. **Streaming Support**: Add effect operations for event streaming \ No newline at end of file diff --git a/domaindriven-effectful/domaindriven-effectful.cabal b/domaindriven-effectful/domaindriven-effectful.cabal index 21023be..688bb9e 100644 --- a/domaindriven-effectful/domaindriven-effectful.cabal +++ b/domaindriven-effectful/domaindriven-effectful.cabal @@ -28,6 +28,7 @@ library exposed-modules: DomainDriven.Effectful DomainDriven.Effectful.Aggregate + DomainDriven.Effectful.Helpers DomainDriven.Effectful.Interpreter.InMemory DomainDriven.Effectful.Projection other-modules: @@ -67,25 +68,60 @@ library TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Weverything -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wno-unused-packages + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wunused-packages + build-depends: + base + , domaindriven-core + , effectful + , hashable + default-language: Haskell2010 + +test-suite domaindriven-effectful-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_domaindriven_effectful + hs-source-dirs: + test + default-extensions: + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedLabels + OverloadedStrings + PolyKinds + RankNTypes + ScopedTypeVariables + StandaloneDeriving + StrictData + TupleSections + TypeApplications + TypeFamilyDependencies + TypeOperators + TypeSynonymInstances + ViewPatterns + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wunused-packages -threaded -rtsopts -with-rtsopts=-N build-depends: aeson , base - , bytestring , domaindriven-core + , domaindriven-effectful , effectful - , effectful-th - , exceptions - , generics-sop - , mtl - , openapi3 - , optics - , servant - , servant-auth-server - , servant-client-core - , servant-openapi3 - , servant-server - , text - , unliftio - , uuid + , hspec default-language: Haskell2010 diff --git a/domaindriven-effectful/package.yaml b/domaindriven-effectful/package.yaml index 73e83e7..42c0b7b 100644 --- a/domaindriven-effectful/package.yaml +++ b/domaindriven-effectful/package.yaml @@ -22,19 +22,7 @@ description: Please see the README on GitHub at event index where + -- This class just establishes the relationship + +-- | Helper for running transactions on NoIndex aggregates +withAggregate + :: forall model event es a + . Aggregate model event NoIndex :> es + => (model -> Eff es (model -> a, [event])) + -> Eff es a +withAggregate = runTransaction @model @event @NoIndex NoIndex + +-- | Helper for querying NoIndex projections +queryModel + :: forall model event es + . Projection model event NoIndex :> es + => Eff es model +queryModel = getModel @model @event @NoIndex + +-- | Helper for getting events from NoIndex projections +queryEvents + :: forall model event es + . Projection model event NoIndex :> es + => Eff es [Stored event] +queryEvents = getEventList @model @event @NoIndex + +-- | Convenience function for simple commands that just emit events +simpleCommand + :: forall model event es a + . Aggregate model event NoIndex :> es + => (model -> a) -- ^ How to extract result from updated model + -> [event] -- ^ Events to emit + -> Eff es a +simpleCommand getResult events = + withAggregate @model @event $ \_ -> pure (getResult, events) + +-- | Convenience function for commands that check the model before emitting events +conditionalCommand + :: forall model event es a + . Aggregate model event NoIndex :> es + => (model -> Maybe [event]) -- ^ Check model and optionally produce events + -> (model -> a) -- ^ Extract result from model + -> Eff es (Maybe a) +conditionalCommand checkModel getResult = + withAggregate @model @event $ \model -> + case checkModel model of + Nothing -> pure (const Nothing, []) + Just events -> pure (Just . getResult, events) \ No newline at end of file diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs index e2dbe49..bce2968 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs @@ -1,7 +1,48 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + module DomainDriven.Effectful.Interpreter.InMemory where import DomainDriven.Effectful.Aggregate import DomainDriven.Effectful.Projection +import DomainDriven.Persistance.Class (WriteModel) +import qualified DomainDriven.Persistance.Class as P +import DomainDriven.Persistance.ForgetfulInMemory import Effectful +import Effectful.Dispatch.Dynamic +import Data.Hashable (Hashable) +import Prelude +-- | Run the Projection effect using an in-memory backend +runProjectionInMemory + :: forall model event index es a + . (Hashable index, IOE :> es) + => ForgetfulInMemory model index event -- ^ The in-memory persistence backend + -> index -- ^ The aggregate index to query + -> Eff (Projection model event index : es) a + -> Eff es a +runProjectionInMemory backend idx = interpret $ \_ -> \case + GetModel -> liftIO $ P.getModel backend idx + GetEventList -> liftIO $ P.getEventList backend idx +-- | Run the Aggregate effect using an in-memory backend +runAggregateInMemory + :: forall model event index es a + . ( IOE :> es + , WriteModel (ForgetfulInMemory model index event) + ) + => ForgetfulInMemory model index event -- ^ The in-memory persistence backend + -> Eff (Aggregate model event index : es) a + -> Eff es a +runAggregateInMemory backend = interpret $ \env -> \case + RunTransaction idx cmd -> do + -- We need to run the effectful command with proper unlift + localSeqUnliftIO env $ \unlift -> do + (model', _, returnFun) <- liftIO $ P.transactionalUpdate backend idx $ \m -> + -- Convert Eff to IO using unlift + unlift (cmd m) + -- Apply the return function to get the final result + pure $ returnFun model' \ No newline at end of file diff --git a/domaindriven-effectful/test/Spec.hs b/domaindriven-effectful/test/Spec.hs new file mode 100644 index 0000000..d7e6867 --- /dev/null +++ b/domaindriven-effectful/test/Spec.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} + +module Main where + +import Test.Hspec +import DomainDriven.Effectful +import DomainDriven.Effectful.Interpreter.InMemory +import DomainDriven.Persistance.Class (Stored(..), NoIndex(..)) +import DomainDriven.Persistance.ForgetfulInMemory (createForgetful) +import Effectful +import Data.Aeson +import GHC.Generics (Generic) +import Prelude + +-------------------------------------------------------------------------------- +-- Test model and events +-------------------------------------------------------------------------------- + +newtype TestModel = TestModel { getValue :: Int } + deriving (Show, Eq, Generic) + +data TestEvent = Add Int | Reset + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +applyTestEvent :: TestModel -> Stored TestEvent -> TestModel +applyTestEvent (TestModel n) (Stored ev _ _) = case ev of + Add x -> TestModel (n + x) + Reset -> TestModel 0 + +-------------------------------------------------------------------------------- +-- Test effects +-------------------------------------------------------------------------------- + +getValue' :: Projection TestModel TestEvent NoIndex :> es => Eff es Int +getValue' = getValue <$> getModel @TestModel @TestEvent @NoIndex + +addValue :: Aggregate TestModel TestEvent NoIndex :> es => Int -> Eff es Int +addValue x = runTransaction @TestModel @TestEvent @NoIndex NoIndex $ \_ -> + pure (getValue, [Add x]) + +resetValue :: Aggregate TestModel TestEvent NoIndex :> es => Eff es Int +resetValue = runTransaction @TestModel @TestEvent @NoIndex NoIndex $ \_ -> + pure (getValue, [Reset]) + +-------------------------------------------------------------------------------- +-- Tests +-------------------------------------------------------------------------------- + +main :: IO () +main = hspec $ do + describe "Projection effect interpreter" $ do + it "should read initial model state" $ do + backend <- createForgetful @NoIndex applyTestEvent (TestModel 42) + result <- runEff + . runProjectionInMemory backend NoIndex + $ getValue' + result `shouldBe` 42 + + it "should read empty event list initially" $ do + backend <- createForgetful @NoIndex applyTestEvent (TestModel 0) + events <- runEff + . runProjectionInMemory backend NoIndex + $ getEventList @TestModel @TestEvent @NoIndex + events `shouldBe` [] + + describe "Aggregate effect interpreter" $ do + it "should handle commands and update state" $ do + backend <- createForgetful @NoIndex applyTestEvent (TestModel 0) + + -- Add 10 + result1 <- runEff + . runAggregateInMemory backend + $ addValue 10 + result1 `shouldBe` 10 + + -- Verify state was updated + currentValue <- runEff + . runProjectionInMemory backend NoIndex + $ getValue' + currentValue `shouldBe` 10 + + -- Add another 5 + result2 <- runEff + . runAggregateInMemory backend + $ addValue 5 + result2 `shouldBe` 15 + + -- Verify final state + finalValue <- runEff + . runProjectionInMemory backend NoIndex + $ getValue' + finalValue `shouldBe` 15 + + it "should store events" $ do + backend <- createForgetful @NoIndex applyTestEvent (TestModel 0) + + -- Perform some operations + _ <- runEff . runAggregateInMemory backend $ addValue 10 + _ <- runEff . runAggregateInMemory backend $ addValue 5 + _ <- runEff . runAggregateInMemory backend $ resetValue + + -- Check events were stored + events <- runEff + . runProjectionInMemory backend NoIndex + $ getEventList @TestModel @TestEvent @NoIndex + + length events `shouldBe` 3 + map storedEvent events `shouldBe` [Add 10, Add 5, Reset] + + it "should handle multiple aggregates with indices" $ do + backend <- createForgetful @Int applyTestEvent (TestModel 0) + + -- Work with aggregate 1 + _ <- runEff . runAggregateInMemory backend $ + runTransaction @TestModel @TestEvent @Int 1 $ \_ -> + pure (getValue, [Add 10]) + + -- Work with aggregate 2 + _ <- runEff . runAggregateInMemory backend $ + runTransaction @TestModel @TestEvent @Int 2 $ \_ -> + pure (getValue, [Add 20]) + + -- Check both aggregates have different states + value1 <- runEff . runProjectionInMemory backend 1 $ + getModel @TestModel @TestEvent @Int + value2 <- runEff . runProjectionInMemory backend 2 $ + getModel @TestModel @TestEvent @Int + + getValue value1 `shouldBe` 10 + getValue value2 `shouldBe` 20 \ No newline at end of file diff --git a/specs/effectful.md b/specs/effectful.md new file mode 100644 index 0000000..35398e6 --- /dev/null +++ b/specs/effectful.md @@ -0,0 +1,18 @@ +We're working on prototyping a rewrite of `domaindriven` to use `Effectful`. + +## The idea + +domaindriven is currently implementing commands using custom servant combinators, `CmdI`, `CbCmdI`, `QueryI`, etc. I want to stop doing that and just use the normal servant endpoint combinators, `Post`, `Query`. This seems super obvious right now, but the history of the library put us in this spot. + +The current prototype use 3 parameters to the Effects. I don't like it, but I'm not sure how to do it without the parameters. I guess it can be simplified using funtional dependencies, `model -> event, model -> index`. + + + +## Work so far + +The initial effects are in: + +- domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs +- domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs + + diff --git a/stack.yaml b/stack.yaml index 4a0f221..1b097dc 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,6 +2,7 @@ resolver: nightly-2025-06-18 packages: - domaindriven-core - domaindriven-effectful +- domaindriven-effectful-examples - domaindriven - domaindriven-examples From 1345f4c4fc3cf940249b53f7ee8190d0d2a2eae4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Tue, 2 Sep 2025 22:14:18 +0200 Subject: [PATCH 16/50] more prototyping --- .../domaindriven-effectful-examples.cabal | 52 ++++++ .../hierarchical-simplified/Main.hs | 173 ++++++++++++++++++ domaindriven-effectful-examples/package.yaml | 17 ++ .../domaindriven-effectful.cabal | 1 + .../src/DomainDriven/Effectful.hs | 6 +- .../src/DomainDriven/Effectful/Aggregate.hs | 31 +++- .../src/DomainDriven/Effectful/Domain.hs | 33 ++++ .../src/DomainDriven/Effectful/Helpers.hs | 56 ++++++ .../Effectful/Interpreter/InMemory.hs | 31 ++++ .../src/DomainDriven/Effectful/Projection.hs | 37 +++- 10 files changed, 432 insertions(+), 5 deletions(-) create mode 100644 domaindriven-effectful-examples/hierarchical-simplified/Main.hs create mode 100644 domaindriven-effectful/src/DomainDriven/Effectful/Domain.hs diff --git a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal index a24c37c..7d885a0 100644 --- a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal +++ b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal @@ -75,6 +75,58 @@ executable hierarchical , warp default-language: Haskell2010 +executable hierarchical-simplified + main-is: Main.hs + other-modules: + Paths_domaindriven_effectful_examples + hs-source-dirs: + hierarchical-simplified + default-extensions: + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedLabels + OverloadedStrings + PolyKinds + RankNTypes + ScopedTypeVariables + StandaloneDeriving + StrictData + TupleSections + TypeApplications + TypeFamilyDependencies + TypeOperators + TypeSynonymInstances + ViewPatterns + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wno-unused-packages -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base + , domaindriven-core + , domaindriven-effectful + , effectful + , microlens + , servant + , servant-server + , warp + default-language: Haskell2010 + executable simple main-is: Main.hs other-modules: diff --git a/domaindriven-effectful-examples/hierarchical-simplified/Main.hs b/domaindriven-effectful-examples/hierarchical-simplified/Main.hs new file mode 100644 index 0000000..a9c16dd --- /dev/null +++ b/domaindriven-effectful-examples/hierarchical-simplified/Main.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} + +module Main where + +import Data.Aeson +import DomainDriven.Persistance.Class (Stored(..), NoIndex(..)) +import DomainDriven.Persistance.ForgetfulInMemory (createForgetful, ForgetfulInMemory) +import DomainDriven.Effectful +import DomainDriven.Effectful.Interpreter.InMemory +import Effectful +import Lens.Micro +import Network.Wai.Handler.Warp (run) +import Servant +import Servant.API.Generic +import Servant.Server.Generic (genericServeT, AsServerT) +import Prelude + +-------------------------------------------------------------------------------- +-- 1. Define the model +-------------------------------------------------------------------------------- + +-- | This does nothing interesting, only carries the sub-models. +data FullModel = FullModel + { numberModel :: NumberModel + , textModel :: TextModel + } + deriving (Show, Eq, Generic) + +newtype NumberModel = NumberModel {numberValue :: Int} + deriving (Show, Eq, Generic) + +newtype TextModel = TextModel {textValue :: String} + deriving (Show, Eq, Generic) + +-------------------------------------------------------------------------------- +-- 2. Define events and how to apply them +-------------------------------------------------------------------------------- +data FullEvent + = NumberEvent NumberEvent + | TextEvent TextEvent + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +data NumberEvent + = SetNumber Int + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +data TextEvent + = SetText String + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +applyEvent :: FullModel -> Stored FullEvent -> FullModel +applyEvent m (Stored ev _ _) = case ev of + NumberEvent ev' -> m & #numberModel %~ (`applyNumberEvent` ev') + TextEvent ev' -> m & #textModel %~ (`applyTextEvent` ev') + +applyNumberEvent :: NumberModel -> NumberEvent -> NumberModel +applyNumberEvent _ ev = case ev of + SetNumber i -> NumberModel i + +applyTextEvent :: TextModel -> TextEvent -> TextModel +applyTextEvent _ ev = case ev of + SetText t -> TextModel t + +-------------------------------------------------------------------------------- +-- 3. Define Domain types - This is the KEY simplification! +-------------------------------------------------------------------------------- + +-- Define domain configurations - just one type parameter each! +type FullDomain = SimpleDomain FullModel FullEvent +type NumberDomain = SimpleDomain NumberModel NumberEvent +type TextDomain = SimpleDomain TextModel TextEvent + +-- Simplified effect constraints using domain types +type FullEffects es = + ( ProjectionD FullDomain Effectful.:> es + , AggregateD FullDomain Effectful.:> es ) + +type NumberEffects es = + ( ProjectionD NumberDomain Effectful.:> es + , AggregateD NumberDomain Effectful.:> es ) + +type TextEffects es = + ( ProjectionD TextDomain Effectful.:> es + , AggregateD TextDomain Effectful.:> es ) + +-------------------------------------------------------------------------------- +-- 4. Define the API using record-based approach with standard Servant combinators +-------------------------------------------------------------------------------- + +data NumberAPI mode = NumberAPI + { getNumber :: mode Servant.:- Get '[JSON] Int + , setNumber :: mode Servant.:- ReqBody '[JSON] Int Servant.:> Post '[JSON] Int + } deriving (Generic) + +data TextAPI mode = TextAPI + { getText :: mode Servant.:- Get '[JSON] String + , setText :: mode Servant.:- ReqBody '[JSON] String Servant.:> Post '[JSON] String + } deriving (Generic) + +data FullAPI mode = FullAPI + { number :: mode Servant.:- "number" Servant.:> NamedRoutes NumberAPI + , text :: mode Servant.:- "text" Servant.:> NamedRoutes TextAPI + } deriving (Generic) + +-------------------------------------------------------------------------------- +-- 5. Implement handlers using Effectful effects with simplified domain API +-------------------------------------------------------------------------------- + +-- Much cleaner! Just one type parameter instead of three! +numberHandlers :: FullEffects es => NumberAPI (AsServerT (Eff es)) +numberHandlers = NumberAPI + { getNumber = do + model <- getModelD @FullDomain -- Single type parameter! + pure $ numberValue (numberModel model) + , setNumber = \n -> + runTransactionD @FullDomain NoIndex $ \_ -> + pure (\m -> numberValue (numberModel m), [NumberEvent (SetNumber n)]) + } + +textHandlers :: FullEffects es => TextAPI (AsServerT (Eff es)) +textHandlers = TextAPI + { getText = do + model <- getModelD @FullDomain -- Single type parameter! + pure $ textValue (textModel model) + , setText = \t -> + runTransactionD @FullDomain NoIndex $ \_ -> + pure (\m -> textValue (textModel m), [TextEvent (SetText t)]) + } + +fullHandlers :: FullEffects es => FullAPI (AsServerT (Eff es)) +fullHandlers = FullAPI + { number = numberHandlers + , text = textHandlers + } + +-------------------------------------------------------------------------------- +-- 6. Wire up the server with effect interpreters +-------------------------------------------------------------------------------- + +mkFullServer :: ForgetfulInMemory FullModel NoIndex FullEvent -> Application +mkFullServer backend = + genericServeT runEffects fullHandlers + where + -- Helper to run effects - using domain-based interpreters + runEffects :: Eff '[ProjectionD FullDomain, + AggregateD FullDomain, + IOE] a -> Handler a + runEffects = liftIO + . runEff + . runAggregateInMemoryD @FullDomain backend + . runProjectionInMemoryD @FullDomain backend NoIndex + +main :: IO () +main = do + let port = 7878 + putStrLn $ "Running Effectful hierarchical example (simplified) on port " <> show port + + -- Initialize with default values + let initialModel = FullModel (NumberModel 0) (TextModel "") + backend <- createForgetful @NoIndex applyEvent initialModel + + -- Create and run the application + let app = mkFullServer backend + + run port app \ No newline at end of file diff --git a/domaindriven-effectful-examples/package.yaml b/domaindriven-effectful-examples/package.yaml index d32eb0d..f116656 100644 --- a/domaindriven-effectful-examples/package.yaml +++ b/domaindriven-effectful-examples/package.yaml @@ -100,6 +100,23 @@ executables: hierarchical: main: Main.hs source-dirs: hierarchical + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - aeson + - domaindriven-core + - domaindriven-effectful + - effectful + - microlens + - servant + - servant-server + - warp + + hierarchical-simplified: + main: Main.hs + source-dirs: hierarchical-simplified ghc-options: - -threaded - -rtsopts diff --git a/domaindriven-effectful/domaindriven-effectful.cabal b/domaindriven-effectful/domaindriven-effectful.cabal index 688bb9e..df8d12c 100644 --- a/domaindriven-effectful/domaindriven-effectful.cabal +++ b/domaindriven-effectful/domaindriven-effectful.cabal @@ -28,6 +28,7 @@ library exposed-modules: DomainDriven.Effectful DomainDriven.Effectful.Aggregate + DomainDriven.Effectful.Domain DomainDriven.Effectful.Helpers DomainDriven.Effectful.Interpreter.InMemory DomainDriven.Effectful.Projection diff --git a/domaindriven-effectful/src/DomainDriven/Effectful.hs b/domaindriven-effectful/src/DomainDriven/Effectful.hs index a7e5488..1c596b5 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful.hs @@ -1,8 +1,12 @@ module DomainDriven.Effectful - ( module X + ( -- * Domain configuration (re-exported) + module DomainDriven.Effectful.Domain + -- * Effects and helpers + , module X ) where +import DomainDriven.Effectful.Domain import DomainDriven.Effectful.Aggregate as X import DomainDriven.Effectful.Projection as X import DomainDriven.Effectful.Helpers as X diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs index b163cb9..124f7bc 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs @@ -1,10 +1,17 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} module DomainDriven.Effectful.Aggregate where +import Data.Kind (Type) +import Data.Proxy (Proxy(..)) import Effectful import Effectful.Dispatch.Dynamic +import DomainDriven.Effectful.Domain +-- | The original Aggregate effect with three type parameters for backward compatibility data Aggregate model event index :: Effect where RunTransaction :: index @@ -13,7 +20,17 @@ data Aggregate model event index :: Effect where type instance DispatchOf (Aggregate model event index) = 'Dynamic --- | Run a synchronous transaction while holding a lock on the aggregate +-- | The new Aggregate effect with a single domain parameter +data Aggregate' (domain :: Type) :: Effect where + RunTransaction' + :: Proxy domain + -> DomainIndex domain + -> (DomainModel domain -> Eff es (DomainModel domain -> a, [DomainEvent domain])) + -> Aggregate' domain (Eff es) a + +type instance DispatchOf (Aggregate' domain) = 'Dynamic + +-- | Run a synchronous transaction while holding a lock on the aggregate (original API) runTransaction :: forall model event index es a . Aggregate model event index :> es @@ -21,3 +38,15 @@ runTransaction -> (model -> Eff es (model -> a, [event])) -> Eff es a runTransaction idx cmd = send (RunTransaction idx cmd) + +-- | Run a synchronous transaction while holding a lock on the aggregate (new domain-based API) +runTransactionD + :: forall domain es a + . Aggregate' domain :> es + => DomainIndex domain + -> (DomainModel domain -> Eff es (DomainModel domain -> a, [DomainEvent domain])) + -> Eff es a +runTransactionD idx cmd = send (RunTransaction' (Proxy @domain) idx cmd) + +-- | Type alias to make migration easier - use Aggregate' with Domain type +type AggregateD domain = Aggregate' domain diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Domain.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Domain.hs new file mode 100644 index 0000000..c84f6cc --- /dev/null +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Domain.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} + +module DomainDriven.Effectful.Domain + ( -- * Domain configuration + Domain(..) + , DomainModel + , DomainEvent + , DomainIndex + , SimpleDomain + ) where + +import Data.Kind (Type) +import DomainDriven.Persistance.Class (NoIndex) + +-- | A domain configuration that bundles model, event, and index types +data Domain (model :: Type) (event :: Type) (index :: Type) = Domain + +-- | Extract the model type from a domain +type family DomainModel domain where + DomainModel (Domain m e i) = m + +-- | Extract the event type from a domain +type family DomainEvent domain where + DomainEvent (Domain m e i) = e + +-- | Extract the index type from a domain +type family DomainIndex domain where + DomainIndex (Domain m e i) = i + +-- | A simplified domain for the common case of NoIndex +type SimpleDomain model event = Domain model event NoIndex \ No newline at end of file diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Helpers.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Helpers.hs index 5595f65..439a874 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Helpers.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Helpers.hs @@ -8,6 +8,7 @@ module DomainDriven.Effectful.Helpers where import DomainDriven.Effectful.Aggregate import DomainDriven.Effectful.Projection +import DomainDriven.Effectful.Domain import DomainDriven.Persistance.Class (Stored, NoIndex(..)) import Effectful import Prelude @@ -58,6 +59,61 @@ conditionalCommand -> Eff es (Maybe a) conditionalCommand checkModel getResult = withAggregate @model @event $ \model -> + case checkModel model of + Nothing -> pure (const Nothing, []) + Just events -> pure (Just . getResult, events) + +-- ============================================================================ +-- Domain-based helper functions (using single type parameter) +-- ============================================================================ + +-- | Helper for running transactions on domains +withAggregateD + :: forall domain es a + . ( Aggregate' domain :> es + , DomainIndex domain ~ NoIndex + ) + => (DomainModel domain -> Eff es (DomainModel domain -> a, [DomainEvent domain])) + -> Eff es a +withAggregateD = runTransactionD @domain NoIndex + +-- | Helper for querying domain projections +queryModelD + :: forall domain es + . Projection' domain :> es + => Eff es (DomainModel domain) +queryModelD = getModelD @domain + +-- | Helper for getting events from domain projections +queryEventsD + :: forall domain es + . Projection' domain :> es + => Eff es [Stored (DomainEvent domain)] +queryEventsD = getEventListD @domain + +-- | Convenience function for simple commands that just emit events (domain version) +simpleCommandD + :: forall domain es a + . ( Aggregate' domain :> es + , DomainIndex domain ~ NoIndex + ) + => (DomainModel domain -> a) -- ^ How to extract result from updated model + -> [DomainEvent domain] -- ^ Events to emit + -> Eff es a +simpleCommandD getResult events = + withAggregateD @domain $ \_ -> pure (getResult, events) + +-- | Convenience function for commands that check the model before emitting events (domain version) +conditionalCommandD + :: forall domain es a + . ( Aggregate' domain :> es + , DomainIndex domain ~ NoIndex + ) + => (DomainModel domain -> Maybe [DomainEvent domain]) -- ^ Check model and optionally produce events + -> (DomainModel domain -> a) -- ^ Extract result from model + -> Eff es (Maybe a) +conditionalCommandD checkModel getResult = + withAggregateD @domain $ \model -> case checkModel model of Nothing -> pure (const Nothing, []) Just events -> pure (Just . getResult, events) \ No newline at end of file diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs index bce2968..de1c5f6 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs @@ -3,11 +3,14 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} module DomainDriven.Effectful.Interpreter.InMemory where import DomainDriven.Effectful.Aggregate import DomainDriven.Effectful.Projection +import DomainDriven.Effectful.Domain import DomainDriven.Persistance.Class (WriteModel) import qualified DomainDriven.Persistance.Class as P import DomainDriven.Persistance.ForgetfulInMemory @@ -45,4 +48,32 @@ runAggregateInMemory backend = interpret $ \env -> \case -- Convert Eff to IO using unlift unlift (cmd m) -- Apply the return function to get the final result + pure $ returnFun model' + +-- | Run the Projection' effect using an in-memory backend (new domain API) +runProjectionInMemoryD + :: forall domain es a + . ( Hashable (DomainIndex domain), IOE :> es) + => ForgetfulInMemory (DomainModel domain) (DomainIndex domain) (DomainEvent domain) + -> DomainIndex domain + -> Eff (Projection' domain : es) a + -> Eff es a +runProjectionInMemoryD backend idx = interpret $ \_ -> \case + GetModel' _ -> liftIO $ P.getModel backend idx + GetEventList' _ -> liftIO $ P.getEventList backend idx + +-- | Run the Aggregate' effect using an in-memory backend (new domain API) +runAggregateInMemoryD + :: forall domain es a + . ( IOE :> es + , WriteModel (ForgetfulInMemory (DomainModel domain) (DomainIndex domain) (DomainEvent domain)) + ) + => ForgetfulInMemory (DomainModel domain) (DomainIndex domain) (DomainEvent domain) + -> Eff (Aggregate' domain : es) a + -> Eff es a +runAggregateInMemoryD backend = interpret $ \env -> \case + RunTransaction' _ idx cmd -> do + localSeqUnliftIO env $ \unlift -> do + (model', _, returnFun) <- liftIO $ P.transactionalUpdate backend idx $ \m -> + unlift (cmd m) pure $ returnFun model' \ No newline at end of file diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs index 0a30039..4023b11 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs @@ -1,29 +1,60 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} module DomainDriven.Effectful.Projection where +import Data.Kind (Type) +import Data.Proxy (Proxy(..)) import Effectful import Effectful.Dispatch.Dynamic import DomainDriven.Persistance.Class (Stored) +import DomainDriven.Effectful.Domain +-- | The original Projection effect with three type parameters for backward compatibility data Projection model event index :: Effect where GetModel :: Projection model event index m model GetEventList ::Projection model event index m [Stored event] type instance DispatchOf (Projection model event index) = 'Dynamic --- | Get the model +-- | The new Projection effect with a single domain parameter +-- We use a proxy to carry the domain type explicitly +data Projection' (domain :: Type) :: Effect where + GetModel' :: Proxy domain -> Projection' domain m (DomainModel domain) + GetEventList' :: Proxy domain -> Projection' domain m [Stored (DomainEvent domain)] + +type instance DispatchOf (Projection' domain) = 'Dynamic + +-- | Get the model (original API) getModel :: forall model event index es . Projection model event index :> es => Eff es model getModel = send (GetModel @model @event @index) - --- | Get a list of all the events used to create the model +-- | Get a list of all the events used to create the model (original API) getEventList :: forall model event index es . Projection model event index :> es => Eff es [Stored event] getEventList = send (GetEventList @model @event @index) +-- | Get the model (new domain-based API) +getModelD + :: forall domain es + . Projection' domain :> es + => Eff es (DomainModel domain) +getModelD = send (GetModel' (Proxy @domain)) + +-- | Get a list of all the events used to create the model (new domain-based API) +getEventListD + :: forall domain es + . Projection' domain :> es + => Eff es [Stored (DomainEvent domain)] +getEventListD = send (GetEventList' (Proxy @domain)) + +-- | Type alias to make migration easier - use Projection' with Domain type +type ProjectionD domain = Projection' domain + From f0bd9eab34467efd7555046facdfcc6dc5bd7e99 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Fri, 12 Sep 2025 09:51:36 +0200 Subject: [PATCH 17/50] clean up --- .../domaindriven-effectful-examples.cabal | 155 ---------------- .../hierarchical-simplified/Main.hs | 173 ------------------ .../hierarchical/Main.hs | 158 ---------------- domaindriven-effectful-examples/package.yaml | 49 ----- .../simple-with-helpers/Main.hs | 97 ---------- .../simple/Main.hs | 28 +-- domaindriven-effectful/ChangeLog.md | 5 - domaindriven-effectful/IMPLEMENTATION.md | 81 -------- domaindriven-effectful/README.md | 128 ------------- .../domaindriven-effectful.cabal | 51 ------ domaindriven-effectful/package.yaml | 13 -- .../src/DomainDriven/Effectful.hs | 1 - .../src/DomainDriven/Effectful/Aggregate.hs | 65 +++---- .../src/DomainDriven/Effectful/Domain.hs | 23 +-- .../src/DomainDriven/Effectful/Helpers.hs | 119 ------------ .../Effectful/Interpreter/InMemory.hs | 55 ++---- .../src/DomainDriven/Effectful/Projection.hs | 51 ++---- domaindriven-effectful/test/Spec.hs | 132 ------------- .../domaindriven-examples.cabal | 4 +- domaindriven-examples/package.yaml | 1 - 20 files changed, 72 insertions(+), 1317 deletions(-) delete mode 100644 domaindriven-effectful-examples/hierarchical-simplified/Main.hs delete mode 100644 domaindriven-effectful-examples/hierarchical/Main.hs delete mode 100644 domaindriven-effectful-examples/simple-with-helpers/Main.hs delete mode 100644 domaindriven-effectful/ChangeLog.md delete mode 100644 domaindriven-effectful/IMPLEMENTATION.md delete mode 100644 domaindriven-effectful/README.md delete mode 100644 domaindriven-effectful/src/DomainDriven/Effectful/Helpers.hs delete mode 100644 domaindriven-effectful/test/Spec.hs diff --git a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal index 7d885a0..7810f42 100644 --- a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal +++ b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal @@ -23,110 +23,6 @@ source-repository head type: git location: https://github.com/tommyengstrom/domaindriven -executable hierarchical - main-is: Main.hs - other-modules: - Paths_domaindriven_effectful_examples - hs-source-dirs: - hierarchical - default-extensions: - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveFunctor - DeriveGeneric - DeriveTraversable - DerivingStrategies - DuplicateRecordFields - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NoImplicitPrelude - OverloadedLabels - OverloadedStrings - PolyKinds - RankNTypes - ScopedTypeVariables - StandaloneDeriving - StrictData - TupleSections - TypeApplications - TypeFamilyDependencies - TypeOperators - TypeSynonymInstances - ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wno-unused-packages -threaded -rtsopts -with-rtsopts=-N - build-depends: - aeson - , base - , domaindriven-core - , domaindriven-effectful - , effectful - , microlens - , servant - , servant-server - , warp - default-language: Haskell2010 - -executable hierarchical-simplified - main-is: Main.hs - other-modules: - Paths_domaindriven_effectful_examples - hs-source-dirs: - hierarchical-simplified - default-extensions: - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveFunctor - DeriveGeneric - DeriveTraversable - DerivingStrategies - DuplicateRecordFields - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NoImplicitPrelude - OverloadedLabels - OverloadedStrings - PolyKinds - RankNTypes - ScopedTypeVariables - StandaloneDeriving - StrictData - TupleSections - TypeApplications - TypeFamilyDependencies - TypeOperators - TypeSynonymInstances - ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wno-unused-packages -threaded -rtsopts -with-rtsopts=-N - build-depends: - aeson - , base - , domaindriven-core - , domaindriven-effectful - , effectful - , microlens - , servant - , servant-server - , warp - default-language: Haskell2010 - executable simple main-is: Main.hs other-modules: @@ -177,54 +73,3 @@ executable simple , servant-server , warp default-language: Haskell2010 - -executable simple-with-helpers - main-is: Main.hs - other-modules: - Paths_domaindriven_effectful_examples - hs-source-dirs: - simple-with-helpers - default-extensions: - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveFunctor - DeriveGeneric - DeriveTraversable - DerivingStrategies - DuplicateRecordFields - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NoImplicitPrelude - OverloadedLabels - OverloadedStrings - PolyKinds - RankNTypes - ScopedTypeVariables - StandaloneDeriving - StrictData - TupleSections - TypeApplications - TypeFamilyDependencies - TypeOperators - TypeSynonymInstances - ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wno-unused-packages -threaded -rtsopts -with-rtsopts=-N - build-depends: - aeson - , base - , domaindriven-core - , domaindriven-effectful - , effectful - , servant - , servant-server - , warp - default-language: Haskell2010 diff --git a/domaindriven-effectful-examples/hierarchical-simplified/Main.hs b/domaindriven-effectful-examples/hierarchical-simplified/Main.hs deleted file mode 100644 index a9c16dd..0000000 --- a/domaindriven-effectful-examples/hierarchical-simplified/Main.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} - -module Main where - -import Data.Aeson -import DomainDriven.Persistance.Class (Stored(..), NoIndex(..)) -import DomainDriven.Persistance.ForgetfulInMemory (createForgetful, ForgetfulInMemory) -import DomainDriven.Effectful -import DomainDriven.Effectful.Interpreter.InMemory -import Effectful -import Lens.Micro -import Network.Wai.Handler.Warp (run) -import Servant -import Servant.API.Generic -import Servant.Server.Generic (genericServeT, AsServerT) -import Prelude - --------------------------------------------------------------------------------- --- 1. Define the model --------------------------------------------------------------------------------- - --- | This does nothing interesting, only carries the sub-models. -data FullModel = FullModel - { numberModel :: NumberModel - , textModel :: TextModel - } - deriving (Show, Eq, Generic) - -newtype NumberModel = NumberModel {numberValue :: Int} - deriving (Show, Eq, Generic) - -newtype TextModel = TextModel {textValue :: String} - deriving (Show, Eq, Generic) - --------------------------------------------------------------------------------- --- 2. Define events and how to apply them --------------------------------------------------------------------------------- -data FullEvent - = NumberEvent NumberEvent - | TextEvent TextEvent - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -data NumberEvent - = SetNumber Int - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -data TextEvent - = SetText String - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -applyEvent :: FullModel -> Stored FullEvent -> FullModel -applyEvent m (Stored ev _ _) = case ev of - NumberEvent ev' -> m & #numberModel %~ (`applyNumberEvent` ev') - TextEvent ev' -> m & #textModel %~ (`applyTextEvent` ev') - -applyNumberEvent :: NumberModel -> NumberEvent -> NumberModel -applyNumberEvent _ ev = case ev of - SetNumber i -> NumberModel i - -applyTextEvent :: TextModel -> TextEvent -> TextModel -applyTextEvent _ ev = case ev of - SetText t -> TextModel t - --------------------------------------------------------------------------------- --- 3. Define Domain types - This is the KEY simplification! --------------------------------------------------------------------------------- - --- Define domain configurations - just one type parameter each! -type FullDomain = SimpleDomain FullModel FullEvent -type NumberDomain = SimpleDomain NumberModel NumberEvent -type TextDomain = SimpleDomain TextModel TextEvent - --- Simplified effect constraints using domain types -type FullEffects es = - ( ProjectionD FullDomain Effectful.:> es - , AggregateD FullDomain Effectful.:> es ) - -type NumberEffects es = - ( ProjectionD NumberDomain Effectful.:> es - , AggregateD NumberDomain Effectful.:> es ) - -type TextEffects es = - ( ProjectionD TextDomain Effectful.:> es - , AggregateD TextDomain Effectful.:> es ) - --------------------------------------------------------------------------------- --- 4. Define the API using record-based approach with standard Servant combinators --------------------------------------------------------------------------------- - -data NumberAPI mode = NumberAPI - { getNumber :: mode Servant.:- Get '[JSON] Int - , setNumber :: mode Servant.:- ReqBody '[JSON] Int Servant.:> Post '[JSON] Int - } deriving (Generic) - -data TextAPI mode = TextAPI - { getText :: mode Servant.:- Get '[JSON] String - , setText :: mode Servant.:- ReqBody '[JSON] String Servant.:> Post '[JSON] String - } deriving (Generic) - -data FullAPI mode = FullAPI - { number :: mode Servant.:- "number" Servant.:> NamedRoutes NumberAPI - , text :: mode Servant.:- "text" Servant.:> NamedRoutes TextAPI - } deriving (Generic) - --------------------------------------------------------------------------------- --- 5. Implement handlers using Effectful effects with simplified domain API --------------------------------------------------------------------------------- - --- Much cleaner! Just one type parameter instead of three! -numberHandlers :: FullEffects es => NumberAPI (AsServerT (Eff es)) -numberHandlers = NumberAPI - { getNumber = do - model <- getModelD @FullDomain -- Single type parameter! - pure $ numberValue (numberModel model) - , setNumber = \n -> - runTransactionD @FullDomain NoIndex $ \_ -> - pure (\m -> numberValue (numberModel m), [NumberEvent (SetNumber n)]) - } - -textHandlers :: FullEffects es => TextAPI (AsServerT (Eff es)) -textHandlers = TextAPI - { getText = do - model <- getModelD @FullDomain -- Single type parameter! - pure $ textValue (textModel model) - , setText = \t -> - runTransactionD @FullDomain NoIndex $ \_ -> - pure (\m -> textValue (textModel m), [TextEvent (SetText t)]) - } - -fullHandlers :: FullEffects es => FullAPI (AsServerT (Eff es)) -fullHandlers = FullAPI - { number = numberHandlers - , text = textHandlers - } - --------------------------------------------------------------------------------- --- 6. Wire up the server with effect interpreters --------------------------------------------------------------------------------- - -mkFullServer :: ForgetfulInMemory FullModel NoIndex FullEvent -> Application -mkFullServer backend = - genericServeT runEffects fullHandlers - where - -- Helper to run effects - using domain-based interpreters - runEffects :: Eff '[ProjectionD FullDomain, - AggregateD FullDomain, - IOE] a -> Handler a - runEffects = liftIO - . runEff - . runAggregateInMemoryD @FullDomain backend - . runProjectionInMemoryD @FullDomain backend NoIndex - -main :: IO () -main = do - let port = 7878 - putStrLn $ "Running Effectful hierarchical example (simplified) on port " <> show port - - -- Initialize with default values - let initialModel = FullModel (NumberModel 0) (TextModel "") - backend <- createForgetful @NoIndex applyEvent initialModel - - -- Create and run the application - let app = mkFullServer backend - - run port app \ No newline at end of file diff --git a/domaindriven-effectful-examples/hierarchical/Main.hs b/domaindriven-effectful-examples/hierarchical/Main.hs deleted file mode 100644 index 157158c..0000000 --- a/domaindriven-effectful-examples/hierarchical/Main.hs +++ /dev/null @@ -1,158 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedLabels #-} - -module Main where - -import Data.Aeson -import DomainDriven.Persistance.Class (Stored(..), NoIndex(..)) -import DomainDriven.Persistance.ForgetfulInMemory (createForgetful, ForgetfulInMemory) -import DomainDriven.Effectful -import DomainDriven.Effectful.Interpreter.InMemory -import Effectful -import Lens.Micro -import Network.Wai.Handler.Warp (run) -import Servant -import Servant.API.Generic -import Servant.Server.Generic (genericServeT, AsServerT) -import Prelude - --------------------------------------------------------------------------------- --- 1. Define the model --------------------------------------------------------------------------------- - --- | This does nothing interesting, only carries the sub-models. -data FullModel = FullModel - { numberModel :: NumberModel - , textModel :: TextModel - } - deriving (Show, Eq, Generic) - -newtype NumberModel = NumberModel {numberValue :: Int} - deriving (Show, Eq, Generic) - -newtype TextModel = TextModel {textValue :: String} - deriving (Show, Eq, Generic) - --------------------------------------------------------------------------------- --- 2. Define events and how to apply them --------------------------------------------------------------------------------- -data FullEvent - = NumberEvent NumberEvent - | TextEvent TextEvent - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -data NumberEvent - = SetNumber Int - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -data TextEvent - = SetText String - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -applyEvent :: FullModel -> Stored FullEvent -> FullModel -applyEvent m (Stored ev _ _) = case ev of - NumberEvent ev' -> m & #numberModel %~ (`applyNumberEvent` ev') - TextEvent ev' -> m & #textModel %~ (`applyTextEvent` ev') - -applyNumberEvent :: NumberModel -> NumberEvent -> NumberModel -applyNumberEvent _ ev = case ev of - SetNumber i -> NumberModel i - -applyTextEvent :: TextModel -> TextEvent -> TextModel -applyTextEvent _ ev = case ev of - SetText t -> TextModel t - --------------------------------------------------------------------------------- --- 3. Define the API using record-based approach with standard Servant combinators --------------------------------------------------------------------------------- - -data NumberAPI mode = NumberAPI - { getNumber :: mode Servant.:- Get '[JSON] Int - , setNumber :: mode Servant.:- ReqBody '[JSON] Int Servant.:> Post '[JSON] Int - } deriving (Generic) - -data TextAPI mode = TextAPI - { getText :: mode Servant.:- Get '[JSON] String - , setText :: mode Servant.:- ReqBody '[JSON] String Servant.:> Post '[JSON] String - } deriving (Generic) - -data FullAPI mode = FullAPI - { number :: mode Servant.:- "number" Servant.:> NamedRoutes NumberAPI - , text :: mode Servant.:- "text" Servant.:> NamedRoutes TextAPI - } deriving (Generic) - --------------------------------------------------------------------------------- --- 4. Implement handlers using Effectful effects --------------------------------------------------------------------------------- - --- Number handlers that work with the full model -numberHandlers - :: ( Projection FullModel FullEvent NoIndex Effectful.:> es - , Aggregate FullModel FullEvent NoIndex Effectful.:> es - ) - => NumberAPI (AsServerT (Eff es)) -numberHandlers = NumberAPI - { getNumber = do - model <- getModel @FullModel @FullEvent @NoIndex - pure $ numberValue (numberModel model) - , setNumber = \n -> runTransaction @FullModel @FullEvent @NoIndex NoIndex $ \_ -> - pure (\m -> numberValue (numberModel m), [NumberEvent (SetNumber n)]) - } - --- Text handlers that work with the full model -textHandlers - :: ( Projection FullModel FullEvent NoIndex Effectful.:> es - , Aggregate FullModel FullEvent NoIndex Effectful.:> es - ) - => TextAPI (AsServerT (Eff es)) -textHandlers = TextAPI - { getText = do - model <- getModel @FullModel @FullEvent @NoIndex - pure $ textValue (textModel model) - , setText = \t -> runTransaction @FullModel @FullEvent @NoIndex NoIndex $ \_ -> - pure (\m -> textValue (textModel m), [TextEvent (SetText t)]) - } - --- Full API handlers combining number and text -fullHandlers - :: ( Projection FullModel FullEvent NoIndex Effectful.:> es - , Aggregate FullModel FullEvent NoIndex Effectful.:> es - ) - => FullAPI (AsServerT (Eff es)) -fullHandlers = FullAPI - { number = numberHandlers - , text = textHandlers - } - --------------------------------------------------------------------------------- --- 5. Wire up the server with effect interpreters --------------------------------------------------------------------------------- - -mkFullServer :: ForgetfulInMemory FullModel NoIndex FullEvent -> Application -mkFullServer backend = - genericServeT runEffects fullHandlers - where - -- Helper to run effects - runEffects :: Eff '[Projection FullModel FullEvent NoIndex, - Aggregate FullModel FullEvent NoIndex, - IOE] a -> Handler a - runEffects = liftIO . runEff . runAggregateInMemory backend . runProjectionInMemory backend NoIndex - -main :: IO () -main = do - let port = 7878 - putStrLn $ "Running Effectful hierarchical example on port " <> show port - - -- Initialize with default values - let initialModel = FullModel (NumberModel 0) (TextModel "") - backend <- createForgetful @NoIndex applyEvent initialModel - - -- Create and run the application - let app = mkFullServer backend - - run port app \ No newline at end of file diff --git a/domaindriven-effectful-examples/package.yaml b/domaindriven-effectful-examples/package.yaml index f116656..673cd65 100644 --- a/domaindriven-effectful-examples/package.yaml +++ b/domaindriven-effectful-examples/package.yaml @@ -81,52 +81,3 @@ executables: - servant-server - warp - simple-with-helpers: - main: Main.hs - source-dirs: simple-with-helpers - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - aeson - - domaindriven-core - - domaindriven-effectful - - effectful - - servant - - servant-server - - warp - - hierarchical: - main: Main.hs - source-dirs: hierarchical - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - aeson - - domaindriven-core - - domaindriven-effectful - - effectful - - microlens - - servant - - servant-server - - warp - - hierarchical-simplified: - main: Main.hs - source-dirs: hierarchical-simplified - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - aeson - - domaindriven-core - - domaindriven-effectful - - effectful - - microlens - - servant - - servant-server - - warp \ No newline at end of file diff --git a/domaindriven-effectful-examples/simple-with-helpers/Main.hs b/domaindriven-effectful-examples/simple-with-helpers/Main.hs deleted file mode 100644 index 3e75789..0000000 --- a/domaindriven-effectful-examples/simple-with-helpers/Main.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Main where - -import Data.Aeson -import DomainDriven.Persistance.Class (Stored(..), NoIndex(..)) -import DomainDriven.Persistance.ForgetfulInMemory (createForgetful, ForgetfulInMemory) -import DomainDriven.Effectful -import DomainDriven.Effectful.Interpreter.InMemory -import Effectful -import Network.Wai.Handler.Warp (run) -import Servant -import Servant.API.Generic -import Servant.Server.Generic (genericServeT, AsServerT) -import Prelude - --------------------------------------------------------------------------------- --- 1. Define the model --------------------------------------------------------------------------------- -newtype CounterModel = CounterModel {getCounter :: Int} - deriving (Show, Eq, Generic) - --------------------------------------------------------------------------------- --- 2. Define events and how to apply them --------------------------------------------------------------------------------- -data CounterEvent - = Increase - | Decrease - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -applyEvent :: CounterModel -> Stored CounterEvent -> CounterModel -applyEvent (CounterModel i) (Stored ev _ _) = CounterModel $ case ev of - Increase -> i + 1 - Decrease -> i - 1 - --- Define the EventSourced instance to use helpers -instance EventSourced CounterModel CounterEvent NoIndex - --------------------------------------------------------------------------------- --- 3. Define the API using record-based approach with standard Servant combinators --------------------------------------------------------------------------------- -data CounterAPI mode = CounterAPI - { current :: mode Servant.:- Get '[JSON] Int - , increase :: mode Servant.:- Post '[JSON] Int - , decrease :: mode Servant.:- Post '[JSON] Int - , safeDecrease :: mode Servant.:- "safe-decrease" Servant.:> Post '[JSON] (Maybe Int) - } deriving (Generic) - --------------------------------------------------------------------------------- --- 4. Implement the server handlers using simplified helpers --------------------------------------------------------------------------------- - --- | Counter handlers using simplified helper functions -counterHandlers - :: ( Projection CounterModel CounterEvent NoIndex Effectful.:> es - , Aggregate CounterModel CounterEvent NoIndex Effectful.:> es - ) - => CounterAPI (AsServerT (Eff es)) -counterHandlers = CounterAPI - { current = getCounter <$> queryModel @CounterModel @CounterEvent - , increase = simpleCommand @CounterModel @CounterEvent getCounter [Increase] - , decrease = simpleCommand @CounterModel @CounterEvent getCounter [Decrease] - , safeDecrease = conditionalCommand @CounterModel @CounterEvent - (\(CounterModel n) -> if n > 0 then Just [Decrease] else Nothing) - getCounter - } - --------------------------------------------------------------------------------- --- 5. Wire up the server with effect interpreters --------------------------------------------------------------------------------- - -mkCounterServer :: ForgetfulInMemory CounterModel NoIndex CounterEvent -> Application -mkCounterServer backend = - genericServeT runEffects counterHandlers - where - runEffects :: Eff '[Projection CounterModel CounterEvent NoIndex, - Aggregate CounterModel CounterEvent NoIndex, - IOE] a -> Handler a - runEffects = liftIO . runEff . runAggregateInMemory backend . runProjectionInMemory backend NoIndex - -main :: IO () -main = do - let port = 7878 - putStrLn $ "Running Effectful counter with helpers on port " <> show port - - -- Initialize the in-memory backend - backend <- createForgetful @NoIndex applyEvent (CounterModel 0) - - -- Create and run the application - let app = mkCounterServer backend - - run port app \ No newline at end of file diff --git a/domaindriven-effectful-examples/simple/Main.hs b/domaindriven-effectful-examples/simple/Main.hs index f8d1844..d176e58 100644 --- a/domaindriven-effectful-examples/simple/Main.hs +++ b/domaindriven-effectful-examples/simple/Main.hs @@ -36,6 +36,8 @@ applyEvent (CounterModel i) (Stored ev _ _) = CounterModel $ case ev of Increase -> i + 1 Decrease -> i - 1 + +type CounterDomain = Domain CounterModel CounterEvent NoIndex -------------------------------------------------------------------------------- -- 3. Define the API using record-based approach with standard Servant combinators -------------------------------------------------------------------------------- @@ -50,16 +52,16 @@ data CounterAPI mode = CounterAPI -------------------------------------------------------------------------------- -- | Counter handlers using Effectful effects -counterHandlers - :: ( Projection CounterModel CounterEvent NoIndex Effectful.:> es - , Aggregate CounterModel CounterEvent NoIndex Effectful.:> es +counterHandlers + :: ( Projection CounterDomain Effectful.:> es + , Aggregate CounterDomain Effectful.:> es ) => CounterAPI (AsServerT (Eff es)) counterHandlers = CounterAPI - { current = getCounter <$> getModel @CounterModel @CounterEvent @NoIndex - , increase = runTransaction @CounterModel @CounterEvent @NoIndex NoIndex $ \_ -> + { current = getCounter <$> getModel @CounterDomain + , increase = runTransaction @CounterDomain NoIndex $ \_ -> do pure (getCounter, [Increase]) - , decrease = runTransaction @CounterModel @CounterEvent @NoIndex NoIndex $ \_ -> + , decrease = runTransaction @CounterDomain NoIndex $ \_ -> do pure (getCounter, [Decrease]) } @@ -69,12 +71,12 @@ counterHandlers = CounterAPI -- | Create the counter server with effect interpreters mkCounterServer :: ForgetfulInMemory CounterModel NoIndex CounterEvent -> Application -mkCounterServer backend = +mkCounterServer backend = genericServeT runEffects counterHandlers where -- Helper to run effects and convert to Handler - runEffects :: Eff '[Projection CounterModel CounterEvent NoIndex, - Aggregate CounterModel CounterEvent NoIndex, + runEffects :: Eff '[Projection CounterDomain, + Aggregate CounterDomain, IOE] a -> Handler a runEffects = liftIO . runEff . runAggregateInMemory backend . runProjectionInMemory backend NoIndex @@ -82,11 +84,11 @@ main :: IO () main = do let port = 7878 putStrLn $ "Running Effectful counter on port " <> show port - + -- Initialize the in-memory backend backend <- createForgetful @NoIndex applyEvent (CounterModel 0) - + -- Create and run the application let app = mkCounterServer backend - - run port app \ No newline at end of file + + run port app diff --git a/domaindriven-effectful/ChangeLog.md b/domaindriven-effectful/ChangeLog.md deleted file mode 100644 index bbe5838..0000000 --- a/domaindriven-effectful/ChangeLog.md +++ /dev/null @@ -1,5 +0,0 @@ -# Changelog for domaindriven - -## 0.5.0 - -First release published on hackage. diff --git a/domaindriven-effectful/IMPLEMENTATION.md b/domaindriven-effectful/IMPLEMENTATION.md deleted file mode 100644 index 8eef587..0000000 --- a/domaindriven-effectful/IMPLEMENTATION.md +++ /dev/null @@ -1,81 +0,0 @@ -# DomainDriven Effectful Implementation - -This is a prototype implementation of domaindriven using the Effectful library instead of custom Servant combinators. - -## Key Changes from Original - -### 1. Standard Servant Combinators -- Uses `Get`, `Post` instead of custom `Query`, `Cmd` combinators -- Cleaner separation between HTTP layer and domain logic - -### 2. Effect-based Architecture -Two main effects: -- `Projection`: Read-only queries -- `Aggregate`: Transactional commands with event emission - -### 3. Interpreters -- `runProjectionInMemory`: Connects Projection effect to ForgetfulInMemory backend -- `runAggregateInMemory`: Handles transactional updates with locking - -## Implementation Status - -✅ **Completed:** -- Core effects (Aggregate, Projection) -- In-memory interpreters -- Simple counter example -- Hierarchical model example -- Type parameter helpers -- Basic test suite - -## Type Parameter Simplification - -The current implementation uses 3 type parameters for effects: -```haskell -Aggregate model event index -Projection model event index -``` - -### Potential Improvements: - -1. **Type Families Approach:** -```haskell -class EventSourced model where - type Event model - type Index model -``` - -2. **Functional Dependencies:** -```haskell -class EventSourced model event index | model -> event index -``` - -3. **Helper functions** (implemented): -- `withAggregate` for NoIndex aggregates -- `queryModel` for simple projections -- `simpleCommand` for basic commands - -## Examples - -### Simple Counter -Shows basic usage with NoIndex aggregates and standard Servant API. - -### Hierarchical Model -Demonstrates composition with sub-models and complex event hierarchies. - -### With Helpers -Uses simplified API with helper functions for common patterns. - -## Testing - -Run tests with: -```bash -stack test domaindriven-effectful -``` - -## Next Steps - -1. **Postgres Interpreter**: Implement `runAggregatePostgres` and `runProjectionPostgres` -2. **Performance Benchmarks**: Compare with original implementation -3. **Migration Guide**: Document path from GADT-based to Effectful approach -4. **Error Handling**: Add proper error effects and validation -5. **Streaming Support**: Add effect operations for event streaming \ No newline at end of file diff --git a/domaindriven-effectful/README.md b/domaindriven-effectful/README.md deleted file mode 100644 index 2af6acc..0000000 --- a/domaindriven-effectful/README.md +++ /dev/null @@ -1,128 +0,0 @@ -# DomainDriven - -DomainDriven is a batteries included synchronous event sourcing and CQRS library. The goal of this library is to allow you to implement DDD principles without focusing on the boilerplate. - -It uses `Template Haskell` we generate a Servant server from the specification and we aim to keep the specification as succinct as we can. - -## The idea - -- Use a GADT to specify the actions, what will be translated into `GET`s and `POST`s. -- Make each event update run in a transaction, thereby avoiding the eventual consistency issues commonly associated with event sourcing. - -## How it works - -In order to implement a model in `domaindriven` you have to define: -- The model (current state) -- The events -- How to update the model when new events come in -- The actions (queries and commands) -- How to handle actions - -### Model - -The model is the current state of the system. This is what you normally would keep in a database, but as this is an event sourced system the state is not fundamental as it can be recalculated. - -Currently all implemented persistence strategies all keep the state in memory. - -### Events - -Events are things that happened in the past. The event you define represent all the changes that can occur in the system. - -Events should be specified in past tens. -```haskell - -data Event - = IncreasedCounter - | DecreasedCounter -``` - -### Event handler - -The model is calculated as a fold over the stream of events. As events happened in the past we can never refuse to handle them. This means the event handler is simply: - -``` haskell -applyEvent :: Model -> Stored Event -> Model -``` - -where Stored is defined as: -``` haskell -data Stored a = Stored - { storedEvent :: a - , storedTimestamp :: UTCTime - , storedUUID :: UUID - } -``` - -### Commands - -Commands are defined using a GADT with one type parameter representing the return type. For example: - -``` haskell --- Same as: data StorageAction (x :: ParamPart) method a where -data StorageAction :: Action where - GetFile - :: P x "fileId" UUID - -> StorageAction x Query ByteString - AddFile - :: P x "fileContent" ByteString - -> StorageAction Cmd UUID - RemoveFile - :: P x "fileId" UUID - -> StorageAction Cmd () -``` - -### Action handler - -Actions, in contrast to events, are allowed to fail. If an action succeeds we need to return a value of the type specified by the constructor and, if it was a command, a list of events. The action handler do not update the state. - -In addition you may need to make requests, read from disk, or perform other side effects in order to calculate the result. - -`ActionHandler` is defined as: - -``` haskell -type ActionHandler model event m c = - forall method a. c 'ParamType method a -> HandlerType method model event m a -``` - -In practice this means you specify actions as - -```haskell - -data CounterAction x method return where - GetCounter ::CounterAction x Query Int - IncreaseCounter ::CounterAction x Cmd Int - DecreaseCounter ::CounterAction x Cmd Int -``` - -and the corresponding handler as - -```haskell -handleAction :: ActionHandler CounterAction CounterEvent IO a -handleAction = \case - GetCounter -> Query $ pure -- Query is just `model -> IO a` - IncreaseCounter -> Cmd $ \_ -> `model -> IO (model -> a, [CounterEvent])` - pure (id -- return state as is, after the event is applied - , [CounterIncreased]) - DecreaseCounter -> Cmd $ \counter -> do - when (counter < 1) (throwM NegativeNotSupported) - pure (id, [CounterDecreased]) -``` - -A `Query` takes a `model -> m a`, i.e. you get access to the model and the ability to run monadic efficts. `Query`s will be translates into `GET` in the generated API. - -A `Cmd` has the additional ability of emitting events. It takes a `model -> m (model -> a, [event])`. The return value is specified as a function from the updated model to the return type. This way we can, in the Counter example, return the new value after the event handler has run. - - -### Generating the server - - -Now we have defined the core parts of our service. We can now generate the server using the template-haskell function `mkServer`. It takes two arguments: The server config and the name of the GADT representing the actions. E.g. `$(mkServer counterActionConfig ''CounterAction)`. - -The `ServerConfig`, `storeActionConfig` in this example, contains the API options for the for the Action and all it's sub actions, as well as a all parameter names. This can be tenerated with `$(mkServerConfig "counterActionConfig")`, but due to TemplateHaskell's stage restrictions it cannot run in the same file as `mkServer`. - - -### Simple example - -Minimal example can be found in [examples/simple/Main.hs](examples/simple/Main.hs), this uses the model defined in [models/Models/Counter.hs](models/Models/Counter.hs) - - diff --git a/domaindriven-effectful/domaindriven-effectful.cabal b/domaindriven-effectful/domaindriven-effectful.cabal index df8d12c..cc1b587 100644 --- a/domaindriven-effectful/domaindriven-effectful.cabal +++ b/domaindriven-effectful/domaindriven-effectful.cabal @@ -29,7 +29,6 @@ library DomainDriven.Effectful DomainDriven.Effectful.Aggregate DomainDriven.Effectful.Domain - DomainDriven.Effectful.Helpers DomainDriven.Effectful.Interpreter.InMemory DomainDriven.Effectful.Projection other-modules: @@ -76,53 +75,3 @@ library , effectful , hashable default-language: Haskell2010 - -test-suite domaindriven-effectful-test - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Paths_domaindriven_effectful - hs-source-dirs: - test - default-extensions: - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveFunctor - DeriveGeneric - DeriveTraversable - DerivingStrategies - DuplicateRecordFields - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NoImplicitPrelude - OverloadedLabels - OverloadedStrings - PolyKinds - RankNTypes - ScopedTypeVariables - StandaloneDeriving - StrictData - TupleSections - TypeApplications - TypeFamilyDependencies - TypeOperators - TypeSynonymInstances - ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wunused-packages -threaded -rtsopts -with-rtsopts=-N - build-depends: - aeson - , base - , domaindriven-core - , domaindriven-effectful - , effectful - , hspec - default-language: Haskell2010 diff --git a/domaindriven-effectful/package.yaml b/domaindriven-effectful/package.yaml index 42c0b7b..dca45d7 100644 --- a/domaindriven-effectful/package.yaml +++ b/domaindriven-effectful/package.yaml @@ -75,16 +75,3 @@ library: source-dirs: src dependencies: - hashable - -tests: - domaindriven-effectful-test: - main: Spec.hs - source-dirs: test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - domaindriven-effectful - - hspec - - aeson diff --git a/domaindriven-effectful/src/DomainDriven/Effectful.hs b/domaindriven-effectful/src/DomainDriven/Effectful.hs index 1c596b5..6241335 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful.hs @@ -9,5 +9,4 @@ where import DomainDriven.Effectful.Domain import DomainDriven.Effectful.Aggregate as X import DomainDriven.Effectful.Projection as X -import DomainDriven.Effectful.Helpers as X diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs index 124f7bc..3b3e97e 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs @@ -1,52 +1,39 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} module DomainDriven.Effectful.Aggregate where import Data.Kind (Type) -import Data.Proxy (Proxy(..)) +import DomainDriven.Effectful.Domain import Effectful import Effectful.Dispatch.Dynamic -import DomainDriven.Effectful.Domain - --- | The original Aggregate effect with three type parameters for backward compatibility -data Aggregate model event index :: Effect where - RunTransaction - :: index - -> (model -> Eff es (model -> a, [event])) - -> Aggregate model event index (Eff es) a - -type instance DispatchOf (Aggregate model event index) = 'Dynamic -- | The new Aggregate effect with a single domain parameter -data Aggregate' (domain :: Type) :: Effect where - RunTransaction' - :: Proxy domain - -> DomainIndex domain - -> (DomainModel domain -> Eff es (DomainModel domain -> a, [DomainEvent domain])) - -> Aggregate' domain (Eff es) a - -type instance DispatchOf (Aggregate' domain) = 'Dynamic - --- | Run a synchronous transaction while holding a lock on the aggregate (original API) +data Aggregate (domain :: Type) :: Effect where + RunTransaction + :: DomainIndex domain + -> ( DomainModel domain + -> Eff + es + ( DomainModel domain -> a + , [DomainEvent domain] + ) + ) + -> Aggregate domain (Eff es) a + +type instance DispatchOf (Aggregate domain) = 'Dynamic + +-- | Run a synchronous transaction while holding a lock on the aggregate +-- The returnd value is a projection of the model after the events have been applied. runTransaction - :: forall model event index es a - . Aggregate model event index :> es - => index - -> (model -> Eff es (model -> a, [event])) - -> Eff es a -runTransaction idx cmd = send (RunTransaction idx cmd) - --- | Run a synchronous transaction while holding a lock on the aggregate (new domain-based API) -runTransactionD :: forall domain es a - . Aggregate' domain :> es + . Aggregate domain :> es => DomainIndex domain - -> (DomainModel domain -> Eff es (DomainModel domain -> a, [DomainEvent domain])) + -> ( DomainModel domain + -> Eff + es + ( DomainModel domain -> a + , [DomainEvent domain] + ) + ) -> Eff es a -runTransactionD idx cmd = send (RunTransaction' (Proxy @domain) idx cmd) - --- | Type alias to make migration easier - use Aggregate' with Domain type -type AggregateD domain = Aggregate' domain +runTransaction idx cmd = send (RunTransaction @domain idx cmd) diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Domain.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Domain.hs index c84f6cc..b1c0b5c 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Domain.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Domain.hs @@ -1,33 +1,20 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} - module DomainDriven.Effectful.Domain - ( -- * Domain configuration - Domain(..) - , DomainModel - , DomainEvent - , DomainIndex - , SimpleDomain + ( module DomainDriven.Effectful.Domain ) where import Data.Kind (Type) -import DomainDriven.Persistance.Class (NoIndex) -- | A domain configuration that bundles model, event, and index types data Domain (model :: Type) (event :: Type) (index :: Type) = Domain -- | Extract the model type from a domain type family DomainModel domain where - DomainModel (Domain m e i) = m + DomainModel (Domain m e i) = m --- | Extract the event type from a domain +-- | Extract the event type from a domain type family DomainEvent domain where - DomainEvent (Domain m e i) = e + DomainEvent (Domain m e i) = e -- | Extract the index type from a domain type family DomainIndex domain where - DomainIndex (Domain m e i) = i - --- | A simplified domain for the common case of NoIndex -type SimpleDomain model event = Domain model event NoIndex \ No newline at end of file + DomainIndex (Domain m e i) = i diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Helpers.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Helpers.hs deleted file mode 100644 index 439a874..0000000 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Helpers.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FunctionalDependencies #-} - -module DomainDriven.Effectful.Helpers where - -import DomainDriven.Effectful.Aggregate -import DomainDriven.Effectful.Projection -import DomainDriven.Effectful.Domain -import DomainDriven.Persistance.Class (Stored, NoIndex(..)) -import Effectful -import Prelude - --- | Type class to associate events and indices with models --- This uses functional dependencies to reduce type parameters -class EventSourced model event index | model -> event index where - -- This class just establishes the relationship - --- | Helper for running transactions on NoIndex aggregates -withAggregate - :: forall model event es a - . Aggregate model event NoIndex :> es - => (model -> Eff es (model -> a, [event])) - -> Eff es a -withAggregate = runTransaction @model @event @NoIndex NoIndex - --- | Helper for querying NoIndex projections -queryModel - :: forall model event es - . Projection model event NoIndex :> es - => Eff es model -queryModel = getModel @model @event @NoIndex - --- | Helper for getting events from NoIndex projections -queryEvents - :: forall model event es - . Projection model event NoIndex :> es - => Eff es [Stored event] -queryEvents = getEventList @model @event @NoIndex - --- | Convenience function for simple commands that just emit events -simpleCommand - :: forall model event es a - . Aggregate model event NoIndex :> es - => (model -> a) -- ^ How to extract result from updated model - -> [event] -- ^ Events to emit - -> Eff es a -simpleCommand getResult events = - withAggregate @model @event $ \_ -> pure (getResult, events) - --- | Convenience function for commands that check the model before emitting events -conditionalCommand - :: forall model event es a - . Aggregate model event NoIndex :> es - => (model -> Maybe [event]) -- ^ Check model and optionally produce events - -> (model -> a) -- ^ Extract result from model - -> Eff es (Maybe a) -conditionalCommand checkModel getResult = - withAggregate @model @event $ \model -> - case checkModel model of - Nothing -> pure (const Nothing, []) - Just events -> pure (Just . getResult, events) - --- ============================================================================ --- Domain-based helper functions (using single type parameter) --- ============================================================================ - --- | Helper for running transactions on domains -withAggregateD - :: forall domain es a - . ( Aggregate' domain :> es - , DomainIndex domain ~ NoIndex - ) - => (DomainModel domain -> Eff es (DomainModel domain -> a, [DomainEvent domain])) - -> Eff es a -withAggregateD = runTransactionD @domain NoIndex - --- | Helper for querying domain projections -queryModelD - :: forall domain es - . Projection' domain :> es - => Eff es (DomainModel domain) -queryModelD = getModelD @domain - --- | Helper for getting events from domain projections -queryEventsD - :: forall domain es - . Projection' domain :> es - => Eff es [Stored (DomainEvent domain)] -queryEventsD = getEventListD @domain - --- | Convenience function for simple commands that just emit events (domain version) -simpleCommandD - :: forall domain es a - . ( Aggregate' domain :> es - , DomainIndex domain ~ NoIndex - ) - => (DomainModel domain -> a) -- ^ How to extract result from updated model - -> [DomainEvent domain] -- ^ Events to emit - -> Eff es a -simpleCommandD getResult events = - withAggregateD @domain $ \_ -> pure (getResult, events) - --- | Convenience function for commands that check the model before emitting events (domain version) -conditionalCommandD - :: forall domain es a - . ( Aggregate' domain :> es - , DomainIndex domain ~ NoIndex - ) - => (DomainModel domain -> Maybe [DomainEvent domain]) -- ^ Check model and optionally produce events - -> (DomainModel domain -> a) -- ^ Extract result from model - -> Eff es (Maybe a) -conditionalCommandD checkModel getResult = - withAggregateD @domain $ \model -> - case checkModel model of - Nothing -> pure (const Nothing, []) - Just events -> pure (Just . getResult, events) \ No newline at end of file diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs index de1c5f6..69a1997 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs @@ -19,61 +19,30 @@ import Effectful.Dispatch.Dynamic import Data.Hashable (Hashable) import Prelude --- | Run the Projection effect using an in-memory backend -runProjectionInMemory - :: forall model event index es a - . (Hashable index, IOE :> es) - => ForgetfulInMemory model index event -- ^ The in-memory persistence backend - -> index -- ^ The aggregate index to query - -> Eff (Projection model event index : es) a - -> Eff es a -runProjectionInMemory backend idx = interpret $ \_ -> \case - GetModel -> liftIO $ P.getModel backend idx - GetEventList -> liftIO $ P.getEventList backend idx - --- | Run the Aggregate effect using an in-memory backend -runAggregateInMemory - :: forall model event index es a - . ( IOE :> es - , WriteModel (ForgetfulInMemory model index event) - ) - => ForgetfulInMemory model index event -- ^ The in-memory persistence backend - -> Eff (Aggregate model event index : es) a - -> Eff es a -runAggregateInMemory backend = interpret $ \env -> \case - RunTransaction idx cmd -> do - -- We need to run the effectful command with proper unlift - localSeqUnliftIO env $ \unlift -> do - (model', _, returnFun) <- liftIO $ P.transactionalUpdate backend idx $ \m -> - -- Convert Eff to IO using unlift - unlift (cmd m) - -- Apply the return function to get the final result - pure $ returnFun model' - -- | Run the Projection' effect using an in-memory backend (new domain API) -runProjectionInMemoryD +runProjectionInMemory :: forall domain es a . ( Hashable (DomainIndex domain), IOE :> es) => ForgetfulInMemory (DomainModel domain) (DomainIndex domain) (DomainEvent domain) -> DomainIndex domain - -> Eff (Projection' domain : es) a + -> Eff (Projection domain : es) a -> Eff es a -runProjectionInMemoryD backend idx = interpret $ \_ -> \case - GetModel' _ -> liftIO $ P.getModel backend idx - GetEventList' _ -> liftIO $ P.getEventList backend idx +runProjectionInMemory backend idx = interpret $ \_ -> \case + GetModel -> liftIO $ P.getModel backend idx + GetEventList -> liftIO $ P.getEventList backend idx --- | Run the Aggregate' effect using an in-memory backend (new domain API) -runAggregateInMemoryD +-- | Run the Aggregate effect using an in-memory backend (new domain API) +runAggregateInMemory :: forall domain es a . ( IOE :> es , WriteModel (ForgetfulInMemory (DomainModel domain) (DomainIndex domain) (DomainEvent domain)) ) => ForgetfulInMemory (DomainModel domain) (DomainIndex domain) (DomainEvent domain) - -> Eff (Aggregate' domain : es) a + -> Eff (Aggregate domain : es) a -> Eff es a -runAggregateInMemoryD backend = interpret $ \env -> \case - RunTransaction' _ idx cmd -> do +runAggregateInMemory backend = interpret $ \env -> \case + RunTransaction idx cmd -> do localSeqUnliftIO env $ \unlift -> do - (model', _, returnFun) <- liftIO $ P.transactionalUpdate backend idx $ \m -> + (model', _, returnFun) <- liftIO $ P.transactionalUpdate backend idx $ \m -> unlift (cmd m) - pure $ returnFun model' \ No newline at end of file + pure $ returnFun model' diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs index 4023b11..34b42c9 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs @@ -1,60 +1,35 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module DomainDriven.Effectful.Projection where import Data.Kind (Type) -import Data.Proxy (Proxy(..)) +import DomainDriven.Effectful.Domain +import DomainDriven.Persistance.Class (Stored) import Effectful import Effectful.Dispatch.Dynamic -import DomainDriven.Persistance.Class (Stored) -import DomainDriven.Effectful.Domain - --- | The original Projection effect with three type parameters for backward compatibility -data Projection model event index :: Effect where - GetModel :: Projection model event index m model - GetEventList ::Projection model event index m [Stored event] - -type instance DispatchOf (Projection model event index) = 'Dynamic -- | The new Projection effect with a single domain parameter -- We use a proxy to carry the domain type explicitly -data Projection' (domain :: Type) :: Effect where - GetModel' :: Proxy domain -> Projection' domain m (DomainModel domain) - GetEventList' :: Proxy domain -> Projection' domain m [Stored (DomainEvent domain)] +data Projection (domain :: Type) :: Effect where + GetModel :: Projection domain m (DomainModel domain) + GetEventList :: Projection domain m [Stored (DomainEvent domain)] -type instance DispatchOf (Projection' domain) = 'Dynamic - --- | Get the model (original API) -getModel - :: forall model event index es - . Projection model event index :> es - => Eff es model -getModel = send (GetModel @model @event @index) - --- | Get a list of all the events used to create the model (original API) -getEventList - :: forall model event index es - . Projection model event index :> es - => Eff es [Stored event] -getEventList = send (GetEventList @model @event @index) +type instance DispatchOf (Projection domain) = 'Dynamic -- | Get the model (new domain-based API) -getModelD +getModel :: forall domain es - . Projection' domain :> es + . Projection domain :> es => Eff es (DomainModel domain) -getModelD = send (GetModel' (Proxy @domain)) +getModel = send (GetModel @domain) -- | Get a list of all the events used to create the model (new domain-based API) -getEventListD +getEventList :: forall domain es - . Projection' domain :> es + . Projection domain :> es => Eff es [Stored (DomainEvent domain)] -getEventListD = send (GetEventList' (Proxy @domain)) - --- | Type alias to make migration easier - use Projection' with Domain type -type ProjectionD domain = Projection' domain +getEventList = send (GetEventList @domain) diff --git a/domaindriven-effectful/test/Spec.hs b/domaindriven-effectful/test/Spec.hs deleted file mode 100644 index d7e6867..0000000 --- a/domaindriven-effectful/test/Spec.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} - -module Main where - -import Test.Hspec -import DomainDriven.Effectful -import DomainDriven.Effectful.Interpreter.InMemory -import DomainDriven.Persistance.Class (Stored(..), NoIndex(..)) -import DomainDriven.Persistance.ForgetfulInMemory (createForgetful) -import Effectful -import Data.Aeson -import GHC.Generics (Generic) -import Prelude - --------------------------------------------------------------------------------- --- Test model and events --------------------------------------------------------------------------------- - -newtype TestModel = TestModel { getValue :: Int } - deriving (Show, Eq, Generic) - -data TestEvent = Add Int | Reset - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -applyTestEvent :: TestModel -> Stored TestEvent -> TestModel -applyTestEvent (TestModel n) (Stored ev _ _) = case ev of - Add x -> TestModel (n + x) - Reset -> TestModel 0 - --------------------------------------------------------------------------------- --- Test effects --------------------------------------------------------------------------------- - -getValue' :: Projection TestModel TestEvent NoIndex :> es => Eff es Int -getValue' = getValue <$> getModel @TestModel @TestEvent @NoIndex - -addValue :: Aggregate TestModel TestEvent NoIndex :> es => Int -> Eff es Int -addValue x = runTransaction @TestModel @TestEvent @NoIndex NoIndex $ \_ -> - pure (getValue, [Add x]) - -resetValue :: Aggregate TestModel TestEvent NoIndex :> es => Eff es Int -resetValue = runTransaction @TestModel @TestEvent @NoIndex NoIndex $ \_ -> - pure (getValue, [Reset]) - --------------------------------------------------------------------------------- --- Tests --------------------------------------------------------------------------------- - -main :: IO () -main = hspec $ do - describe "Projection effect interpreter" $ do - it "should read initial model state" $ do - backend <- createForgetful @NoIndex applyTestEvent (TestModel 42) - result <- runEff - . runProjectionInMemory backend NoIndex - $ getValue' - result `shouldBe` 42 - - it "should read empty event list initially" $ do - backend <- createForgetful @NoIndex applyTestEvent (TestModel 0) - events <- runEff - . runProjectionInMemory backend NoIndex - $ getEventList @TestModel @TestEvent @NoIndex - events `shouldBe` [] - - describe "Aggregate effect interpreter" $ do - it "should handle commands and update state" $ do - backend <- createForgetful @NoIndex applyTestEvent (TestModel 0) - - -- Add 10 - result1 <- runEff - . runAggregateInMemory backend - $ addValue 10 - result1 `shouldBe` 10 - - -- Verify state was updated - currentValue <- runEff - . runProjectionInMemory backend NoIndex - $ getValue' - currentValue `shouldBe` 10 - - -- Add another 5 - result2 <- runEff - . runAggregateInMemory backend - $ addValue 5 - result2 `shouldBe` 15 - - -- Verify final state - finalValue <- runEff - . runProjectionInMemory backend NoIndex - $ getValue' - finalValue `shouldBe` 15 - - it "should store events" $ do - backend <- createForgetful @NoIndex applyTestEvent (TestModel 0) - - -- Perform some operations - _ <- runEff . runAggregateInMemory backend $ addValue 10 - _ <- runEff . runAggregateInMemory backend $ addValue 5 - _ <- runEff . runAggregateInMemory backend $ resetValue - - -- Check events were stored - events <- runEff - . runProjectionInMemory backend NoIndex - $ getEventList @TestModel @TestEvent @NoIndex - - length events `shouldBe` 3 - map storedEvent events `shouldBe` [Add 10, Add 5, Reset] - - it "should handle multiple aggregates with indices" $ do - backend <- createForgetful @Int applyTestEvent (TestModel 0) - - -- Work with aggregate 1 - _ <- runEff . runAggregateInMemory backend $ - runTransaction @TestModel @TestEvent @Int 1 $ \_ -> - pure (getValue, [Add 10]) - - -- Work with aggregate 2 - _ <- runEff . runAggregateInMemory backend $ - runTransaction @TestModel @TestEvent @Int 2 $ \_ -> - pure (getValue, [Add 20]) - - -- Check both aggregates have different states - value1 <- runEff . runProjectionInMemory backend 1 $ - getModel @TestModel @TestEvent @Int - value2 <- runEff . runProjectionInMemory backend 2 $ - getModel @TestModel @TestEvent @Int - - getValue value1 `shouldBe` 10 - getValue value2 `shouldBe` 20 \ No newline at end of file diff --git a/domaindriven-examples/domaindriven-examples.cabal b/domaindriven-examples/domaindriven-examples.cabal index e63a06f..7ae79b4 100644 --- a/domaindriven-examples/domaindriven-examples.cabal +++ b/domaindriven-examples/domaindriven-examples.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.38.0. +-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack @@ -28,7 +28,6 @@ executable hierarchical-example hs-source-dirs: hierarchical default-extensions: - Arrows ConstraintKinds DataKinds DeriveAnyClass @@ -80,7 +79,6 @@ executable simple-example hs-source-dirs: simple default-extensions: - Arrows ConstraintKinds DataKinds DeriveAnyClass diff --git a/domaindriven-examples/package.yaml b/domaindriven-examples/package.yaml index aaca0c5..960ea8c 100644 --- a/domaindriven-examples/package.yaml +++ b/domaindriven-examples/package.yaml @@ -27,7 +27,6 @@ dependencies: default-extensions: -- Arrows - ConstraintKinds - DataKinds - DeriveAnyClass From ed423e2b0c1d26d89cf4c304e12e684bdf5e1823 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Fri, 12 Sep 2025 16:48:47 +0200 Subject: [PATCH 18/50] fix various things --- .../domaindriven-effectful-examples.cabal | 3 +- domaindriven-effectful-examples/package.yaml | 3 +- .../simple/Main.hs | 77 ++++++++++++------- domaindriven-effectful/package.yaml | 1 + .../src/DomainDriven/Effectful/Aggregate.hs | 6 +- .../Effectful/Interpreter/InMemory.hs | 4 +- stack.yaml | 2 +- 7 files changed, 61 insertions(+), 35 deletions(-) diff --git a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal index 7810f42..1f90aea 100644 --- a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal +++ b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal @@ -23,13 +23,14 @@ source-repository head type: git location: https://github.com/tommyengstrom/domaindriven -executable simple +executable effectful-example main-is: Main.hs other-modules: Paths_domaindriven_effectful_examples hs-source-dirs: simple default-extensions: + BlockArguments ConstraintKinds DataKinds DeriveAnyClass diff --git a/domaindriven-effectful-examples/package.yaml b/domaindriven-effectful-examples/package.yaml index 673cd65..ab33e4f 100644 --- a/domaindriven-effectful-examples/package.yaml +++ b/domaindriven-effectful-examples/package.yaml @@ -19,6 +19,7 @@ dependencies: - base default-extensions: +- BlockArguments - ConstraintKinds - DataKinds - DeriveAnyClass @@ -65,7 +66,7 @@ ghc-options: - -Wno-unused-packages executables: - simple: + effectful-example: main: Main.hs source-dirs: simple ghc-options: diff --git a/domaindriven-effectful-examples/simple/Main.hs b/domaindriven-effectful-examples/simple/Main.hs index d176e58..10dda5a 100644 --- a/domaindriven-effectful-examples/simple/Main.hs +++ b/domaindriven-effectful-examples/simple/Main.hs @@ -1,26 +1,32 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} module Main where +import Control.Monad (when) import Data.Aeson -import DomainDriven.Persistance.Class (Stored(..), NoIndex(..)) -import DomainDriven.Persistance.ForgetfulInMemory (createForgetful, ForgetfulInMemory) import DomainDriven.Effectful import DomainDriven.Effectful.Interpreter.InMemory -import Effectful +import DomainDriven.Persistance.Class (NoIndex (..), Stored (..)) +import DomainDriven.Persistance.ForgetfulInMemory (ForgetfulInMemory, createForgetful) +import Effectful hiding ((:>)) +import Effectful qualified +import Effectful.Error.Static import Network.Wai.Handler.Warp (run) -import Servant +import Servant hiding (throwError) +import Servant qualified import Servant.API.Generic -import Servant.Server.Generic (genericServeT, AsServerT) +import Servant.Server.Generic (AsServerT, genericServeT) import Prelude -------------------------------------------------------------------------------- -- 1. Define the model -------------------------------------------------------------------------------- -newtype CounterModel = CounterModel {getCounter :: Int} +newtype CounterModel = CounterModel + { getCounter :: Int + } deriving (Show, Eq, Generic) -------------------------------------------------------------------------------- @@ -36,34 +42,41 @@ applyEvent (CounterModel i) (Stored ev _ _) = CounterModel $ case ev of Increase -> i + 1 Decrease -> i - 1 - type CounterDomain = Domain CounterModel CounterEvent NoIndex + -------------------------------------------------------------------------------- --- 3. Define the API using record-based approach with standard Servant combinators +-- 3. Define the Servant API -------------------------------------------------------------------------------- data CounterAPI mode = CounterAPI - { current :: mode Servant.:- Get '[JSON] Int - , increase :: mode Servant.:- Post '[JSON] Int - , decrease :: mode Servant.:- Post '[JSON] Int - } deriving (Generic) + { get :: mode :- Get '[JSON] Int + , increase :: mode :- "increase" :> Post '[JSON] Int + , decrease :: mode :- "decrease" :> Post '[JSON] Int + } + deriving (Generic) -------------------------------------------------------------------------------- -- 4. Implement the server handlers using Effectful effects -------------------------------------------------------------------------------- -- | Counter handlers using Effectful effects -counterHandlers +counterServer :: ( Projection CounterDomain Effectful.:> es , Aggregate CounterDomain Effectful.:> es + , Error ServerError Effectful.:> es ) => CounterAPI (AsServerT (Eff es)) -counterHandlers = CounterAPI - { current = getCounter <$> getModel @CounterDomain - , increase = runTransaction @CounterDomain NoIndex $ \_ -> do - pure (getCounter, [Increase]) - , decrease = runTransaction @CounterDomain NoIndex $ \_ -> do - pure (getCounter, [Decrease]) - } +counterServer = + CounterAPI + { get = getCounter <$> getModel @CounterDomain + , increase = runTransaction @CounterDomain NoIndex do + pure (getCounter, [Increase]) + , decrease = runTransaction @CounterDomain NoIndex do + m <- getModel @CounterDomain + when (getCounter m <= 0) + . throwError + $ err422{errBody = "Counter cannot go below zero"} + pure (getCounter, [Decrease]) + } -------------------------------------------------------------------------------- -- 5. Wire up the server with effect interpreters @@ -72,13 +85,25 @@ counterHandlers = CounterAPI -- | Create the counter server with effect interpreters mkCounterServer :: ForgetfulInMemory CounterModel NoIndex CounterEvent -> Application mkCounterServer backend = - genericServeT runEffects counterHandlers + genericServeT runEffects counterServer where -- Helper to run effects and convert to Handler - runEffects :: Eff '[Projection CounterDomain, - Aggregate CounterDomain, - IOE] a -> Handler a - runEffects = liftIO . runEff . runAggregateInMemory backend . runProjectionInMemory backend NoIndex + runEffects + :: Eff + '[ Projection CounterDomain + , Aggregate CounterDomain + , Error ServerError + , IOE + ] + a + -> Handler a + runEffects m = do + a <- liftIO + . runEff + . runErrorNoCallStack @ServerError + . runAggregateInMemory backend + $ runProjectionInMemory backend NoIndex m + either Servant.throwError pure a main :: IO () main = do diff --git a/domaindriven-effectful/package.yaml b/domaindriven-effectful/package.yaml index dca45d7..edaea01 100644 --- a/domaindriven-effectful/package.yaml +++ b/domaindriven-effectful/package.yaml @@ -25,6 +25,7 @@ dependencies: - domaindriven-core + default-extensions: - ConstraintKinds - DataKinds diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs index 3b3e97e..478667b 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs @@ -11,8 +11,7 @@ import Effectful.Dispatch.Dynamic data Aggregate (domain :: Type) :: Effect where RunTransaction :: DomainIndex domain - -> ( DomainModel domain - -> Eff + -> (Eff es ( DomainModel domain -> a , [DomainEvent domain] @@ -28,8 +27,7 @@ runTransaction :: forall domain es a . Aggregate domain :> es => DomainIndex domain - -> ( DomainModel domain - -> Eff + -> ( Eff es ( DomainModel domain -> a , [DomainEvent domain] diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs index 69a1997..9a6630c 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs @@ -43,6 +43,6 @@ runAggregateInMemory runAggregateInMemory backend = interpret $ \env -> \case RunTransaction idx cmd -> do localSeqUnliftIO env $ \unlift -> do - (model', _, returnFun) <- liftIO $ P.transactionalUpdate backend idx $ \m -> - unlift (cmd m) + (model', _, returnFun) <- liftIO $ P.transactionalUpdate backend idx $ \_ -> + unlift cmd pure $ returnFun model' diff --git a/stack.yaml b/stack.yaml index 1b097dc..06023c5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2025-06-18 +resolver: lts-24.9 packages: - domaindriven-core - domaindriven-effectful From a46d232ad7910289c3dc62eb260ec09c043db06c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Fri, 12 Sep 2025 17:27:34 +0200 Subject: [PATCH 19/50] remove model parameter for command in `runTransaction` --- .../src/DomainDriven/Persistance/Class.hs | 7 ++++--- .../DomainDriven/Persistance/ForgetfulInMemory.hs | 6 +++--- .../DomainDriven/Persistance/Postgres/Internal.hs | 14 +++++++------- .../DomainDriven/Effectful/Interpreter/InMemory.hs | 8 ++++---- 4 files changed, 18 insertions(+), 17 deletions(-) diff --git a/domaindriven-core/src/DomainDriven/Persistance/Class.hs b/domaindriven-core/src/DomainDriven/Persistance/Class.hs index 5ad642f..98f266a 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Class.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Class.hs @@ -33,7 +33,7 @@ class ReadModel p where type Event p :: Type type Index p :: Type applyEvent :: p -> Model p -> Stored (Event p) -> Model p - getModel :: HasCallStack => p -> Index p -> IO (Model p) + getModel :: MonadIO m => HasCallStack => p -> Index p -> m (Model p) getEventList :: p -> Index p -> IO [Stored (Event p)] getEventStream :: HasCallStack => p -> Index p -> Stream IO (Stored (Event p)) @@ -59,7 +59,7 @@ class ReadModel p => WriteModel p where . MonadUnliftIO m => p -> Index p - -> (Model p -> m (Model p -> a, [Event p])) + -> m (Model p -> a, [Event p]) -> m ( Model p , -- \^ Updated model @@ -77,7 +77,8 @@ runCmd -> Index p -> RunCmd (Model p) (Event p) m a runCmd p index cmd = withFrozenCallStack $ do - (model, events, returnFun) <- transactionalUpdate p index cmd + (model, events, returnFun) <- transactionalUpdate p index + $ getModel p index >>= cmd _ <- async $ postUpdateHook p index model events pure $ returnFun model diff --git a/domaindriven-core/src/DomainDriven/Persistance/ForgetfulInMemory.hs b/domaindriven-core/src/DomainDriven/Persistance/ForgetfulInMemory.hs index c1c15bc..ea09622 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/ForgetfulInMemory.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/ForgetfulInMemory.hs @@ -41,9 +41,9 @@ instance Hashable index => ReadModel (ForgetfulInMemory model index event) where type Event (ForgetfulInMemory model index event) = event type Index (ForgetfulInMemory model index event) = index applyEvent = apply - getModel :: ForgetfulInMemory model index event + getModel :: MonadIO m => ForgetfulInMemory model index event -> index - -> IO model + -> m model getModel ff index = HM.lookupDefault (seed ff) index <$> readIORef (stateRef ff) getEventList ff index = HM.lookupDefault [] index <$> readIORef (events ff) getEventStream ff index = @@ -56,8 +56,8 @@ instance Hashable index => WriteModel (ForgetfulInMemory model index event) wher postUpdateHook p index model events = liftIO $ updateHook p index model events transactionalUpdate ff index evalCmd = bracket_ (waitQSem $ lock ff) (signalQSem $ lock ff) $ do + (returnFun, evs) <- evalCmd model <- HM.lookupDefault (seed ff) index <$> readIORef (stateRef ff) - (returnFun, evs) <- evalCmd model storedEvs <- traverse toStored evs let newModel = foldl' (apply ff) model storedEvs modifyIORef (events ff) diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs index b57c06f..890c64f 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs @@ -102,7 +102,7 @@ instance (IsPgIndex i, FromJSON e) => ReadModel (PostgresEvent i m e) where type Index (PostgresEvent i m e) = i type Event (PostgresEvent i m e) = e applyEvent pg = pg ^. field @"app" - getModel pg index = withIOTrans pg (`getModel'` index) + getModel pg index = liftIO $ withIOTrans pg (`getModel'` index) getEventList pg index = withResource (connectionPool pg) $ \conn -> fmap fst <$> queryEvents (Pool.resource conn) (pg ^. field @"eventTableName") index @@ -548,10 +548,10 @@ mkEventStream chunkSize conn q = do ) getModel' - :: forall e i m - . (IsPgIndex i, FromJSON e) - => PostgresEventTrans i m e - -> i + :: forall e index m + . (IsPgIndex index, FromJSON e) + => PostgresEventTrans index m e + -> index -> IO m getModel' pgt index = do NumberedModel model lastEventNo <- getCurrentState pgt index @@ -635,8 +635,8 @@ instance (IsPgIndex i, ToJSON e, FromJSON e) => WriteModel (PostgresEvent i m e) transactionalUpdate pg index cmd = withRunInIO $ \runInIO -> withIOTrans pg $ \pgt -> withExclusiveLock pgt index $ do - m <- getModel' pgt index - (returnFun, evs) <- runInIO $ cmd m + --m <- getModel' pgt index + (returnFun, evs) <- runInIO cmd NumberedModel m' _ <- getCurrentState pg index storedEvs <- traverse toStored evs newNumberedModel <- diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs index 9a6630c..b79996a 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs @@ -41,8 +41,8 @@ runAggregateInMemory -> Eff (Aggregate domain : es) a -> Eff es a runAggregateInMemory backend = interpret $ \env -> \case - RunTransaction idx cmd -> do - localSeqUnliftIO env $ \unlift -> do - (model', _, returnFun) <- liftIO $ P.transactionalUpdate backend idx $ \_ -> - unlift cmd + RunTransaction idx cmd -> do + localSeqUnlift env $ \unlift -> do + (model', _, returnFun) <- P.transactionalUpdate backend idx + $ unlift cmd pure $ returnFun model' From 0092d99e6d4a9d600eb1b13140ed03c380a7a5d0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Sat, 13 Sep 2025 01:11:16 +0200 Subject: [PATCH 20/50] I think the effectful version works now, but I broke the old version --- .../src/DomainDriven/Persistance/Class.hs | 7 +- .../DomainDriven/Persistance/PostgresSpec.hs | 20 +- .../simple/Main.hs | 55 ++- .../domaindriven-effectful.cabal | 14 +- domaindriven-effectful/package.yaml | 9 + .../Effectful/Interpreter/Postgres.hs | 56 +++ .../src/DomainDriven/FieldNameAsPath.hs | 324 ++++++++++++++++++ .../src/Servant/Auth/Internal/ThrowAll/SOP.hs | 16 + 8 files changed, 479 insertions(+), 22 deletions(-) create mode 100644 domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs create mode 100644 domaindriven-effectful/src/DomainDriven/FieldNameAsPath.hs create mode 100644 domaindriven-effectful/src/Servant/Auth/Internal/ThrowAll/SOP.hs diff --git a/domaindriven-core/src/DomainDriven/Persistance/Class.hs b/domaindriven-core/src/DomainDriven/Persistance/Class.hs index 98f266a..7591bfb 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Class.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Class.hs @@ -37,7 +37,6 @@ class ReadModel p where getEventList :: p -> Index p -> IO [Stored (Event p)] getEventStream :: HasCallStack => p -> Index p -> Stream IO (Stored (Event p)) -type RunCmd model event m a = (model -> m (model -> a, [event])) -> m a class ReadModel p => WriteModel p where -- | Hook to call after model has been updated. @@ -75,10 +74,10 @@ runCmd . (WriteModel p, MonadUnliftIO m) => p -> Index p - -> RunCmd (Model p) (Event p) m a + -> m (Model p -> a, [Event p]) + -> m a runCmd p index cmd = withFrozenCallStack $ do - (model, events, returnFun) <- transactionalUpdate p index - $ getModel p index >>= cmd + (model, events, returnFun) <- transactionalUpdate p index cmd _ <- async $ postUpdateHook p index model events pure $ returnFun model diff --git a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs index d8d8d31..442c0b8 100644 --- a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs +++ b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs @@ -65,7 +65,7 @@ spec = do postHook p index m evs = do atomically $ modifyTVar processedEvents (<> Set.fromList (fmap storedUUID evs)) - when (m < 0) (void $ runCmd p index $ \_ -> pure (id, [Reset])) + when (m < 0) (void $ runCmd p index $ pure (id, [Reset])) in around (setupPersistance postHook) (postHookSpec processedEvents) around (setupPersistance noHook) migrationConcurrencySpec @@ -208,8 +208,8 @@ indexedSpec = describe "Indexed models" $ do it "Updates to different indices can be done in parallel" $ \(p, _pool) -> do -- This may fail in GHCI. Run it with stack test. - let testCmd :: Int -> TestModel -> IO (TestModel -> TestModel, [TestEvent]) - testCmd i _m = do + let testCmd :: Int -> IO (TestModel -> TestModel, [TestEvent]) + testCmd i = do threadDelay 100000 -- 0.1s delay pure (id, replicate i AddOne) t0 <- getCurrentTime @@ -226,8 +226,8 @@ indexedSpec = describe "Indexed models" $ do diffUTCTime t1 t0 `shouldSatisfy` (< 1.9) it "Updates to same index are done sequentially" $ \(p, _pool) -> do - let testCmd :: TestModel -> IO (TestModel -> TestModel, [TestEvent]) - testCmd _m = do + let testCmd :: IO (TestModel -> TestModel, [TestEvent]) + testCmd = do threadDelay 100000 -- 0.1s delay pure (id, [AddOne, AddOne]) t0 <- getCurrentTime @@ -296,7 +296,7 @@ postHookSpec processedEvents = describe "updateHook" $ do events `shouldBe` Set.empty it "Post update hook is fired after events are written" $ \(p, _) -> do - i <- runCmd p NoIndex $ \_ -> do + i <- runCmd p NoIndex $ do pure (id, [AddOne, AddOne, SubtractOne]) i `shouldBe` 1 threadDelay 100000 -- Ensure the hook has time to run @@ -305,7 +305,7 @@ postHookSpec processedEvents = describe "updateHook" $ do it "Hook that resets on negative works" $ \(p, _) -> do -- the hook will check if the model is negative and reset it if so - m <- runCmd p NoIndex $ \_ -> do + m <- runCmd p NoIndex $ do pure (id, [SubtractOne, SubtractOne, SubtractOne]) m `shouldBe` (-3) threadDelay 100000 -- Ensure the hook has time to run @@ -383,8 +383,8 @@ migrationConcurrencySpec = describe "Event table is locked during migration" $ d -> EventMigration -> IO () migrationTest m0 pool mig = do - let cmd :: Int -> IO (Int -> Int, [TestEvent]) - cmd _ = pure (id, [AddOne]) + let cmd :: IO (Int -> Int, [TestEvent]) + cmd = pure (id, [AddOne]) i <- replicateM 5 (runCmd m0 NoIndex cmd) length i `shouldBe` 5 @@ -431,7 +431,7 @@ loggingSpec :: SpecWith (PostgresEvent NoIndex TestModel TestEvent, Pool Connect loggingSpec = describe "Callstacks" $ do it "Callstack for runCmd reference this file" $ \(p', _) -> do (logVar, p) <- withStmLogger p' - _ <- runCmd p NoIndex $ \_ -> pure (id, [AddOne]) + _ <- runCmd p NoIndex $ pure (id, [AddOne]) referencesThisFile =<< readTVarIO logVar it "Callstack for getModel reference this file" $ \(p', _) -> do (logVar, p) <- withStmLogger p' diff --git a/domaindriven-effectful-examples/simple/Main.hs b/domaindriven-effectful-examples/simple/Main.hs index 10dda5a..cc200fd 100644 --- a/domaindriven-effectful-examples/simple/Main.hs +++ b/domaindriven-effectful-examples/simple/Main.hs @@ -9,6 +9,7 @@ import Control.Monad (when) import Data.Aeson import DomainDriven.Effectful import DomainDriven.Effectful.Interpreter.InMemory +import DomainDriven.FieldNameAsPath import DomainDriven.Persistance.Class (NoIndex (..), Stored (..)) import DomainDriven.Persistance.ForgetfulInMemory (ForgetfulInMemory, createForgetful) import Effectful hiding ((:>)) @@ -52,7 +53,7 @@ data CounterAPI mode = CounterAPI , increase :: mode :- "increase" :> Post '[JSON] Int , decrease :: mode :- "decrease" :> Post '[JSON] Int } - deriving (Generic) + deriving (Generic, ApiTagFromLabel) -------------------------------------------------------------------------------- -- 4. Implement the server handlers using Effectful effects @@ -65,6 +66,7 @@ counterServer , Error ServerError Effectful.:> es ) => CounterAPI (AsServerT (Eff es)) + counterServer = CounterAPI { get = getCounter <$> getModel @CounterDomain @@ -78,6 +80,44 @@ counterServer = pure (getCounter, [Decrease]) } +counterServer' + :: ( Projection CounterDomain Effectful.:> es + , Aggregate CounterDomain Effectful.:> es + , Error ServerError Effectful.:> es + ) + => ServerT (FieldNameAsPathApi CounterAPI) (Eff es) +counterServer' = FieldNameAsPathServer counterServer + +-- + +-- | Create the counter server with effect interpreters +mkCounterServer' :: ForgetfulInMemory CounterModel NoIndex CounterEvent -> Application +mkCounterServer' backend = + serveWithContextT + (Proxy @(FieldNameAsPathApi CounterAPI)) + EmptyContext + runEffects + counterServer' + where + -- Helper to run effects and convert to Handler + runEffects + :: Eff + '[ Projection CounterDomain + , Aggregate CounterDomain + , Error ServerError + , IOE + ] + a + -> Handler a + runEffects m = do + a <- + liftIO + . runEff + . runErrorNoCallStack @ServerError + . runAggregateInMemory backend + $ runProjectionInMemory backend NoIndex m + either Servant.throwError pure a + -------------------------------------------------------------------------------- -- 5. Wire up the server with effect interpreters -------------------------------------------------------------------------------- @@ -98,11 +138,12 @@ mkCounterServer backend = a -> Handler a runEffects m = do - a <- liftIO - . runEff - . runErrorNoCallStack @ServerError - . runAggregateInMemory backend - $ runProjectionInMemory backend NoIndex m + a <- + liftIO + . runEff + . runErrorNoCallStack @ServerError + . runAggregateInMemory backend + $ runProjectionInMemory backend NoIndex m either Servant.throwError pure a main :: IO () @@ -114,6 +155,6 @@ main = do backend <- createForgetful @NoIndex applyEvent (CounterModel 0) -- Create and run the application - let app = mkCounterServer backend + let app = mkCounterServer' backend run port app diff --git a/domaindriven-effectful/domaindriven-effectful.cabal b/domaindriven-effectful/domaindriven-effectful.cabal index cc1b587..02b9d89 100644 --- a/domaindriven-effectful/domaindriven-effectful.cabal +++ b/domaindriven-effectful/domaindriven-effectful.cabal @@ -30,7 +30,10 @@ library DomainDriven.Effectful.Aggregate DomainDriven.Effectful.Domain DomainDriven.Effectful.Interpreter.InMemory + DomainDriven.Effectful.Interpreter.Postgres DomainDriven.Effectful.Projection + DomainDriven.FieldNameAsPath + Servant.Auth.Internal.ThrowAll.SOP other-modules: Paths_domaindriven_effectful hs-source-dirs: @@ -70,8 +73,17 @@ library ViewPatterns ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wunused-packages build-depends: - base + aeson + , base + , bytestring , domaindriven-core , effectful + , generics-sop , hashable + , openapi3 + , servant-auth-server + , servant-client-core + , servant-openapi3 + , servant-server + , text default-language: Haskell2010 diff --git a/domaindriven-effectful/package.yaml b/domaindriven-effectful/package.yaml index edaea01..3204384 100644 --- a/domaindriven-effectful/package.yaml +++ b/domaindriven-effectful/package.yaml @@ -23,6 +23,15 @@ dependencies: - base - effectful - domaindriven-core +- aeson +- servant-server +- servant-client-core +- servant-openapi3 +- openapi3 +- servant-auth-server +- generics-sop +- text +- bytestring diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs new file mode 100644 index 0000000..7fac541 --- /dev/null +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module DomainDriven.Effectful.Interpreter.Postgres where + +import Data.Aeson +import DomainDriven.Effectful.Aggregate +import DomainDriven.Effectful.Domain +import DomainDriven.Effectful.Projection +import DomainDriven.Persistance.Class (WriteModel) +import DomainDriven.Persistance.Class qualified as P +import DomainDriven.Persistance.Postgres.Internal +import DomainDriven.Persistance.Postgres.Types +import Effectful +import Effectful.Dispatch.Dynamic +import Prelude + +-- | Run the Projection' effect using an in-memory backend (new domain API) +runProjectionPostgres + :: forall domain es a index + . ( IOE :> es + , FromJSON (DomainEvent domain) + , IsPgIndex index + , index ~ (DomainIndex domain) + , P.Index (PostgresEvent (DomainModel domain) (DomainIndex domain) (DomainEvent domain)) + ~ index + ) + => PostgresEvent (DomainModel domain) (DomainIndex domain) (DomainEvent domain) + -> DomainIndex domain + -> Eff (Projection domain : es) a + -> Eff es a +runProjectionPostgres backend idx = interpret $ \_ -> \case + GetModel -> liftIO $ P.getModel backend idx + GetEventList -> liftIO $ P.getEventList backend idx + +-- | Run the Aggregate effect using an in-memory backend (new domain API) +runAggregateInMemory + :: forall domain es a index + . ( IOE :> es + , index ~ (DomainIndex domain) + , P.Index (PostgresEvent (DomainModel domain) (DomainIndex domain) (DomainEvent domain)) + ~ index + , WriteModel (PostgresEvent (DomainModel domain) (DomainIndex domain) (DomainEvent domain)) + ) + => PostgresEvent (DomainModel domain) (DomainIndex domain) (DomainEvent domain) + -> Eff (Aggregate domain : es) a + -> Eff es a +runAggregateInMemory backend = interpret $ \env -> \case + RunTransaction idx cmd -> do + localSeqUnlift env $ \unlift -> + P.runCmd backend idx $ unlift cmd diff --git a/domaindriven-effectful/src/DomainDriven/FieldNameAsPath.hs b/domaindriven-effectful/src/DomainDriven/FieldNameAsPath.hs new file mode 100644 index 0000000..2a0b769 --- /dev/null +++ b/domaindriven-effectful/src/DomainDriven/FieldNameAsPath.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE UndecidableInstances #-} + +module DomainDriven.FieldNameAsPath where + +import Data.ByteString.Builder qualified as Builder +import Data.Kind +import Data.OpenApi (OpenApi, prependPath) +import Data.Text qualified as Text +import GHC.Generics qualified as GHC +import GHC.TypeLits +import Generics.SOP + ( I (..) + , NP (..) + , NS (..) + , SOP (..) + , unSOP + ) +import Generics.SOP.GGP +import Generics.SOP.Type.Metadata +import Servant +import Servant.Auth.Internal.ThrowAll.SOP () +import Servant.Auth.Server.Internal.ThrowAll +import Servant.Client.Core +import Servant.Client.Generic +import Servant.OpenApi +import Servant.Server.Generic +import Servant.Server.Internal.Delayed +import Servant.Server.Internal.Router +import Prelude + + +-- | Wrapper around the data structure containing the API and endpoint definitions. +-- The endpoints name in the record will be added to the path. For example: +-- ``` +-- data CounterAction mode = CounterAction +-- { increaseWith :: mode :- "something" :> ReqBody '[JSON] Int :> Cmd Int +-- } +-- ``` +-- Will result in a Post endpoint with path "something/increaseWith". +data FieldNameAsPathApi (mkApiRecord :: Type -> Type) + +class ApiTagFromLabel (mkApiRecord :: Type -> Type) where + apiTagFromLabel :: String -> String + apiTagFromLabel = id + +-- | Wrapper around the data structure containing the API and endpoint definitions. +-- This is used to carry the expectation of `HasServer` for `FieldNameAsPath`. i.e. +-- this is what the `ServerT` type family will produce when given a `FieldNameAsPath`. +newtype + FieldNameAsPathServer + (mkServerRecord :: Type -> Type) + (m :: Type -> Type) = FieldNameAsPathServer + { unDomainDrivenServer + :: mkServerRecord (AsServerT m) + } + +deriving newtype instance + GHC.Generic (mkServerRecord (AsServerT m)) + => GHC.Generic (FieldNameAsPathServer mkServerRecord m) + +class DomainDrivenServerFields (mkApiRecord :: Type -> Type) (m :: Type -> Type) where + recordOfServersFromFields + :: NP I (ServerTs (GenericRecordFields (mkApiRecord AsApi)) m) + -> mkApiRecord (AsServerT m) + recordOfServersToFields + :: mkApiRecord (AsServerT m) + -> NP I (ServerTs (GenericRecordFields (mkApiRecord AsApi)) m) + +instance + ( GHC.Generic (mkApiRecord (AsServerT m)) + , GCode (mkApiRecord (AsServerT m)) + ~ '[ServerTs (GenericRecordFields (mkApiRecord AsApi)) m] + , GFrom (mkApiRecord (AsServerT m)) + , GTo (mkApiRecord (AsServerT m)) + ) + => DomainDrivenServerFields mkApiRecord m + where + recordOfServersFromFields = gto . SOP . Z + recordOfServersToFields x = case unSOP $ gfrom x of + Z servers -> servers + S y -> case y of {} + +class + FieldNamesInPathHasServers + (mkApiRecord :: Type -> Type) + (apis :: [Type]) + (infos :: [FieldInfo]) + (context :: [Type]) + where + type ServerTs apis (m :: Type -> Type) :: [Type] + taggedSumOfRoutes + :: Context context + -> Delayed env (NP I (ServerTs apis Handler)) + -> Router env + hoistTaggedServersWithContext + :: (forall x. m x -> n x) + -> NP I (ServerTs apis m) + -> NP I (ServerTs apis n) + +instance FieldNamesInPathHasServers mkApiRecord '[] '[] context where + type ServerTs '[] m = '[] + taggedSumOfRoutes _ _ = StaticRouter mempty mempty + hoistTaggedServersWithContext _ Nil = Nil + +instance + ( HasServer api context + , FieldNamesInPathHasServers mkApiRecord apis infos context + , KnownSymbol label + , ApiTagFromLabel mkApiRecord + ) + => FieldNamesInPathHasServers + mkApiRecord + (api ': apis) + ('FieldInfo label ': infos) + context + where + type ServerTs (api ': apis) m = ServerT api m ': ServerTs apis m + + taggedSumOfRoutes context delayedServers = + choice + ( pathRouter + (Text.pack $ apiTagFromLabel @mkApiRecord $ symbolVal (Proxy @label)) + $ route (Proxy @api) context + $ (\(I server :* _) -> server) <$> delayedServers + ) + ( taggedSumOfRoutes @mkApiRecord @apis @infos context $ + (\(_ :* servers) -> servers) <$> delayedServers + ) + + hoistTaggedServersWithContext nt (I server :* servers) = + I (hoistServerWithContext (Proxy @api) (Proxy @context) nt server) + :* hoistTaggedServersWithContext @mkApiRecord @apis @infos @context nt servers + +instance + ( FieldNamesInPathHasServers + mkApiRecord + (GenericRecordFields (mkApiRecord AsApi)) + (GenericRecordFieldInfos (mkApiRecord AsApi)) + context + , forall m. DomainDrivenServerFields (mkApiRecord ) m + ) + => HasServer (FieldNameAsPathApi mkApiRecord ) context + where + type + ServerT (FieldNameAsPathApi mkApiRecord ) m = + FieldNameAsPathServer mkApiRecord m + + route _ context delayedServer = + taggedSumOfRoutes @mkApiRecord + @(GenericRecordFields (mkApiRecord AsApi)) + @(GenericRecordFieldInfos (mkApiRecord AsApi)) + context + (recordOfServersToFields . unDomainDrivenServer <$> delayedServer) + + hoistServerWithContext _ _ nt servers = + FieldNameAsPathServer + . recordOfServersFromFields + . hoistTaggedServersWithContext @mkApiRecord + @(GenericRecordFields (mkApiRecord AsApi)) + @(GenericRecordFieldInfos (mkApiRecord AsApi)) + @context + nt + . recordOfServersToFields + $ unDomainDrivenServer servers + +class + FieldNamesInPathHasOpenApi + (mkApiRecord :: Type -> Type) + (apis :: [Type]) + (infos :: [FieldInfo]) + where + domainDrivenApiToOpenApi :: OpenApi + +instance FieldNamesInPathHasOpenApi mkApiRecord '[] '[] where + domainDrivenApiToOpenApi = mempty + +instance + ( KnownSymbol label + , ApiTagFromLabel mkApiRecord + , HasOpenApi api + , FieldNamesInPathHasOpenApi mkApiRecord apis infos + ) + => FieldNamesInPathHasOpenApi mkApiRecord (api ': apis) ('FieldInfo label ': infos) + where + domainDrivenApiToOpenApi = + prependPath + (apiTagFromLabel @mkApiRecord $ symbolVal (Proxy @label)) + (toOpenApi (Proxy @api)) + <> domainDrivenApiToOpenApi @mkApiRecord @apis @infos + +instance + FieldNamesInPathHasOpenApi + mkApiRecord + (GenericRecordFields (mkApiRecord AsApi)) + (GenericRecordFieldInfos (mkApiRecord AsApi)) + => HasOpenApi (FieldNameAsPathApi mkApiRecord ) + where + toOpenApi _ = + domainDrivenApiToOpenApi @mkApiRecord + @(GenericRecordFields (mkApiRecord AsApi)) + @(GenericRecordFieldInfos (mkApiRecord AsApi)) + +instance + ( GHC.Generic (FieldNameAsPathServer mkServerRecord m) + , GTo (FieldNameAsPathServer mkServerRecord m) + , ThrowAll (SOP I (GCode (FieldNameAsPathServer mkServerRecord m))) + ) + => ThrowAll (FieldNameAsPathServer mkServerRecord m) + where + throwAll = gto . throwAll @(SOP I (GCode (FieldNameAsPathServer mkServerRecord m))) + +class + FieldNamesInPathHasClients + (m :: Type -> Type) + (mkApiRecord :: Type -> Type) + (apis :: [Type]) + (infos :: [FieldInfo]) + where + type Clients apis m :: [Type] + clientsWithRoute :: Request -> NP I (Clients apis m) + hoistClientsMonad + :: (forall x. mon x -> mon' x) + -> NP I (Clients apis mon) + -> NP I (Clients apis mon') + +instance FieldNamesInPathHasClients m mkApiRecord '[] '[] where + type Clients '[] m = '[] + clientsWithRoute _ = Nil + hoistClientsMonad _ Nil = Nil + +instance + ( HasClient m api + , FieldNamesInPathHasClients m mkApiRecord apis infos + , KnownSymbol label + , ApiTagFromLabel mkApiRecord + ) + => FieldNamesInPathHasClients m mkApiRecord (api ': apis) ('FieldInfo label ': infos) + where + type Clients (api ': apis) m = Client m api ': Clients apis m + + clientsWithRoute req = + I + ( clientWithRoute + (Proxy @m) + (Proxy @api) + ( appendToPath + (Builder.stringUtf8 $ apiTagFromLabel @mkApiRecord $ symbolVal (Proxy @label)) + req + ) + ) + :* clientsWithRoute @m @mkApiRecord @apis @infos req + hoistClientsMonad nt (I client :* clients) = + I (hoistClientMonad (Proxy @m) (Proxy @api) nt client) + :* hoistClientsMonad @m @mkApiRecord @apis @infos nt clients + +class DomainDrivenClientFields (mkApiRecord :: Type -> Type) (m :: Type -> Type) where + recordOfClientsFromFields + :: NP I (Clients (GenericRecordFields (mkApiRecord AsApi)) m) + -> mkApiRecord (AsClientT m) + recordOfClientsToFields + :: mkApiRecord (AsClientT m) + -> NP I (Clients (GenericRecordFields (mkApiRecord AsApi)) m) + +instance + ( GHC.Generic (mkApiRecord (AsClientT m)) + , GCode (mkApiRecord (AsClientT m)) + ~ '[Clients (GenericRecordFields (mkApiRecord AsApi)) m] + , GFrom (mkApiRecord (AsClientT m)) + , GTo (mkApiRecord (AsClientT m)) + ) + => DomainDrivenClientFields mkApiRecord m + where + recordOfClientsFromFields = gto . SOP . Z + recordOfClientsToFields x = case unSOP $ gfrom x of + Z servers -> servers + S y -> case y of {} + +instance + ( RunClient m + , FieldNamesInPathHasClients + m + mkApiRecord + (GenericRecordFields (mkApiRecord AsApi)) + (GenericRecordFieldInfos (mkApiRecord AsApi)) + , forall n. DomainDrivenClientFields (mkApiRecord ) n + ) + => HasClient m (FieldNameAsPathApi mkApiRecord ) + where + type + Client m (FieldNameAsPathApi mkApiRecord ) = + mkApiRecord (AsClientT m) + clientWithRoute _ _ = + recordOfClientsFromFields + . ( clientsWithRoute @m @mkApiRecord + @(GenericRecordFields (mkApiRecord AsApi)) + @(GenericRecordFieldInfos (mkApiRecord AsApi)) + ) + hoistClientMonad _ _ nt = + recordOfClientsFromFields + . hoistClientsMonad @m @mkApiRecord + @(GenericRecordFields (mkApiRecord AsApi)) + @(GenericRecordFieldInfos (mkApiRecord AsApi)) + nt + . recordOfClientsToFields + + + + +type family GenericRecordFields (record :: Type) :: [Type] where + GenericRecordFields record = GenericRecordFields' (GCode record) + +type family GenericRecordFields' (code :: [[Type]]) :: [Type] where + GenericRecordFields' '[fields] = fields + GenericRecordFields' t = TypeError ('ShowType t ':<>: 'Text " is not a record!") + +type family GenericRecordFieldInfos (record :: Type) :: [FieldInfo] where + GenericRecordFieldInfos record = GenericRecordFieldInfos' (GDatatypeInfoOf record) + +type family GenericRecordFieldInfos' (info :: DatatypeInfo) :: [FieldInfo] where + GenericRecordFieldInfos' ('ADT _ _ '[ 'Record _ infos] _) = infos + GenericRecordFieldInfos' t = TypeError ('ShowType t ':<>: 'Text " is not a record!") diff --git a/domaindriven-effectful/src/Servant/Auth/Internal/ThrowAll/SOP.hs b/domaindriven-effectful/src/Servant/Auth/Internal/ThrowAll/SOP.hs new file mode 100644 index 0000000..09a7d0c --- /dev/null +++ b/domaindriven-effectful/src/Servant/Auth/Internal/ThrowAll/SOP.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Servant.Auth.Internal.ThrowAll.SOP where + +import Generics.SOP (I (..), NP (Nil, (:*)), NS (..), SOP (..)) +import Servant.Auth.Server.Internal.ThrowAll +import Prelude + +instance ThrowAll (NP I '[]) where + throwAll _ = Nil + +instance (ThrowAll (NP I cs), ThrowAll c) => ThrowAll (NP I (c ': cs)) where + throwAll err = I (throwAll err) :* throwAll err + +instance ThrowAll (NP I servers) => ThrowAll (SOP I '[servers]) where + throwAll = SOP . Z . throwAll From f18d4b266b24f57fc2d7d3e4d8877cfc673c8d0d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Sat, 13 Sep 2025 07:03:15 +0200 Subject: [PATCH 21/50] include ShapeCoercible --- domaindriven-core/domaindriven-core.cabal | 3 +- domaindriven-core/src/Data/ShapeCoercible.hs | 334 +++++++++++++++++++ 2 files changed, 336 insertions(+), 1 deletion(-) create mode 100644 domaindriven-core/src/Data/ShapeCoercible.hs diff --git a/domaindriven-core/domaindriven-core.cabal b/domaindriven-core/domaindriven-core.cabal index 758f7c9..34767c5 100644 --- a/domaindriven-core/domaindriven-core.cabal +++ b/domaindriven-core/domaindriven-core.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.38.0. +-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack @@ -27,6 +27,7 @@ source-repository head library exposed-modules: + Data.ShapeCoercible DomainDriven.Persistance.Class DomainDriven.Persistance.ForgetfulInMemory DomainDriven.Persistance.Postgres diff --git a/domaindriven-core/src/Data/ShapeCoercible.hs b/domaindriven-core/src/Data/ShapeCoercible.hs new file mode 100644 index 0000000..8d3ba5b --- /dev/null +++ b/domaindriven-core/src/Data/ShapeCoercible.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-operator-whitespace #-} + +module Data.ShapeCoerce where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as M +import GHC.Generics +import GHC.TypeLits +import Prelude + +gshapeCoerce :: forall a b. (Generic a, Generic b, GShapeCoercible a b (Rep a) (Rep b)) => a -> b +gshapeCoerce = to . gscoerce @a @b . from + +-- Though intuitively two types are coercible iff they are isomorphic let's be +-- explicit about it. +type ShapeIsomorphic a b = (ShapeCoercible a b, ShapeCoercible b a) + +class ShapeCoercible a b where + shapeCoerce :: a -> b + +instance + {-# OVERLAPPABLE #-} + (Generic a, Generic b, GShapeCoercible a b (Rep a) (Rep b)) => + ShapeCoercible a b + where + shapeCoerce = to . gscoerce @a @b . from + +instance (ShapeCoercible a c, ShapeCoercible b d, Ord c) => ShapeCoercible (Map a b) (Map c d) where + shapeCoerce = M.mapKeys shapeCoerce . M.map shapeCoerce + +instance {-# OVERLAPPING #-} ShapeCoercible a a where + shapeCoerce = id + +class GShapeCoercible x y a b where + gscoerce :: a x -> b x + +instance + forall x y f1 f2 datatypeName a1 b1 c1 a2 b2 c2. + (GShapeCoercible x y f1 f2) => + GShapeCoercible x y + (M1 D ('MetaData datatypeName a1 b1 c1) f1) + (M1 D ('MetaData datatypeName a2 b2 c2) f2) + where + gscoerce = M1 . gscoerce @x @y . unM1 + +-- Better error for incompatible data types +instance + {-# OVERLAPPABLE #-} + forall x y f1 f2 datatypeName1 datatypeName2 a1 b1 c1 a2 b2 c2. + ( TypeError + ( 'Text "Cannot shapeCoerce between types:" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Incompatible data types" + ':$$: 'Text " From type: " ':<>: 'ShowType datatypeName1 + ':$$: 'Text " To type: " ':<>: 'ShowType datatypeName2 + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ) + ) => + GShapeCoercible x y + (M1 D ('MetaData datatypeName1 a1 b1 c1) f1) + (M1 D ('MetaData datatypeName2 a2 b2 c2) f2) + where + gscoerce = error "unreachable" + +-- Matching constructor names with same structure +instance + (GShapeCoercible x y f1 f2) => + GShapeCoercible x y + (M1 C ('MetaCons constructorName b c) f1) + (M1 C ('MetaCons constructorName b c) f2) + where + gscoerce = M1 . gscoerce @x @y . unM1 + +-- Same constructor name but different structure +instance + {-# OVERLAPPABLE #-} + forall x y f1 f2 name b1 c1 b2 c2. + ( TypeError + ( 'Text "Cannot shapeCoerce between types:" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Constructor " ':<>: 'ShowType name ':<>: 'Text " has different field structures" + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ) + ) => + GShapeCoercible x y + (M1 C ('MetaCons name b1 c1) f1) + (M1 C ('MetaCons name b2 c2) f2) + where + gscoerce = error "unreachable" + +-- Different constructor names +instance + {-# OVERLAPPABLE #-} + forall x y f1 f2 cName1 cName2 b1 c1 b2 c2. + ( TypeError + ( 'Text "Cannot shapeCoerce between types:" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Constructor name mismatch" + ':$$: 'Text " " ':<>: 'ShowType cName1 ':<>: 'Text " ≠ " ':<>: 'ShowType cName2 + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ) + ) => + GShapeCoercible x y + (M1 C ('MetaCons cName1 b1 c1) f1) + (M1 C ('MetaCons cName2 b2 c2) f2) + where + gscoerce = error "unreachable" + +instance + (GShapeCoercible x y f1 f2) => + GShapeCoercible x y + (M1 S ('MetaSel selectorName a1 b1 c1) f1) + (M1 S ('MetaSel selectorName a2 b2 c2) f2) + where + gscoerce = M1 . gscoerce @x @y . unM1 + +-- Instance for mismatched selector names +instance + {-# OVERLAPPABLE #-} + forall x y f1 f2 name1 name2 a1 b1 c1 a2 b2 c2. + ( TypeError + ( 'Text "Cannot shapeCoerce between types:" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Field name mismatch" + ':$$: 'Text " Expected: " ':<>: 'ShowType name1 + ':$$: 'Text " But got: " ':<>: 'ShowType name2 + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ) + ) => + GShapeCoercible x y + (M1 S ('MetaSel name1 a1 b1 c1) f1) + (M1 S ('MetaSel name2 a2 b2 c2) f2) + where + gscoerce = error "unreachable" + +instance + (GShapeCoercible x y a1 a2, GShapeCoercible x y b1 b2) => + GShapeCoercible x y (a1 :*: b1) (a2 :*: b2) + where + gscoerce (a :*: b) = gscoerce @x @y a :*: gscoerce @x @y b + +instance + (GShapeCoercible x y a1 a2, GShapeCoercible x y b1 b2) => + GShapeCoercible x y (a1 :+: b1) (a2 :+: b2) + where + gscoerce (L1 a) = L1 $ gscoerce @x @y a + gscoerce (R1 b) = R1 $ gscoerce @x @y b + +-- Single constructor vs sum type (left to right) +instance + {-# OVERLAPPABLE #-} + forall x y c name b p f rest. + ( TypeError + ( 'Text "Cannot shapeCoerce between types:" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Left side has a single constructor but right side is a sum type" + ':$$: 'Text "Left constructor: " ':<>: 'ShowType name + ':$$: 'Text "Right side: Multiple constructors (sum type)" + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ) + ) => + GShapeCoercible x y (M1 C ('MetaCons name b p) f) (c :+: rest) + where + gscoerce = error "unreachable" + +-- Sum type vs single constructor (right to left) +instance + {-# OVERLAPPABLE #-} + forall x y c name b p f rest. + ( TypeError + ( 'Text "Cannot shapeCoerce between types:" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Left side is a sum type but right side has a single constructor" + ':$$: 'Text "Right constructor: " ':<>: 'ShowType name + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ) + ) => + GShapeCoercible x y (c :+: rest) (M1 C ('MetaCons name b p) f) + where + gscoerce = error "unreachable" + + +instance GShapeCoercible x y U1 U1 where + gscoerce = id + +-- Better error for U1 vs field mismatch +instance + {-# OVERLAPPABLE #-} + forall x y name a b c t. + ( TypeError + ( 'Text "Cannot shapeCoerce between types:" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Constructor has no fields but expected field: " ':<>: 'ShowType name + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ) + ) => + GShapeCoercible x y U1 (M1 S ('MetaSel name a b c) t) + where + gscoerce = error "unreachable" + +-- Better error for field vs U1 mismatch +instance + {-# OVERLAPPABLE #-} + forall x y name a b c t. + ( TypeError + ( 'Text "Cannot shapeCoerce between types:" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Constructor has field " ':<>: 'ShowType name ':<>: 'Text " but none expected" + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ) + ) => + GShapeCoercible x y (M1 S ('MetaSel name a b c) t) U1 + where + gscoerce = error "unreachable" + +-- Instance for U1 vs product (fields) +instance + {-# OVERLAPPABLE #-} + forall x y a b. + ( TypeError + ( 'Text "Cannot shapeCoerce between types:" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Constructor has no fields but expected multiple fields" + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ) + ) => + GShapeCoercible x y U1 (a :*: b) + where + gscoerce = error "unreachable" + +-- Instance for product vs U1 +instance + {-# OVERLAPPABLE #-} + forall x y a b. + ( TypeError + ( 'Text "Cannot shapeCoerce between types:" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Constructor has fields but none expected" + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ) + ) => + GShapeCoercible x y (a :*: b) U1 + where + gscoerce = error "unreachable" + +-- Instance for single field vs product (multiple fields) +instance + {-# OVERLAPPABLE #-} + forall x y s meta f rest. + ( TypeError + ( 'Text "Cannot shapeCoerce between types:" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Field count mismatch (single field vs multiple fields)" + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ) + ) => + GShapeCoercible x y (M1 S meta f) (s :*: rest) + where + gscoerce = error "unreachable" + +-- Instance for product vs single field +instance + {-# OVERLAPPABLE #-} + forall x y s meta f rest. + ( TypeError + ( 'Text "Cannot shapeCoerce between types:" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Field count mismatch (multiple fields vs single field)" + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ) + ) => + GShapeCoercible x y (s :*: rest) (M1 S meta f) + where + gscoerce = error "unreachable" + +instance GShapeCoercible x y (M1 S s (Rec0 ())) U1 where + gscoerce _ = U1 + +instance + (ShapeCoercible c1 c2) => + GShapeCoercible x y (Rec0 c1) (Rec0 c2) + where + gscoerce (K1 x) = K1 $ shapeCoerce x + From 935580d791d9563956f3a050eae6b649fba7bf5c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Sat, 13 Sep 2025 08:23:37 +0200 Subject: [PATCH 22/50] use plugin and improve examples --- domaindriven-core/domaindriven-core.cabal | 8 +- domaindriven-core/package.yaml | 2 + .../{ShapeCoercible.hs => ShapeCoerce.hs} | 0 .../domaindriven-effectful-examples.cabal | 4 +- domaindriven-effectful-examples/package.yaml | 3 + .../simple-named/Main.hs | 132 ++++++++++++++++++ .../simple/Main.hs | 74 +++------- .../domaindriven-effectful.cabal | 3 +- domaindriven-effectful/package.yaml | 3 + .../src/DomainDriven/Effectful/Aggregate.hs | 43 ++++-- .../Effectful/Interpreter/InMemory.hs | 9 +- .../src/DomainDriven/Effectful/Projection.hs | 29 ++-- 12 files changed, 221 insertions(+), 89 deletions(-) rename domaindriven-core/src/Data/{ShapeCoercible.hs => ShapeCoerce.hs} (100%) create mode 100644 domaindriven-effectful-examples/simple-named/Main.hs diff --git a/domaindriven-core/domaindriven-core.cabal b/domaindriven-core/domaindriven-core.cabal index 34767c5..8fef729 100644 --- a/domaindriven-core/domaindriven-core.cabal +++ b/domaindriven-core/domaindriven-core.cabal @@ -27,7 +27,7 @@ source-repository head library exposed-modules: - Data.ShapeCoercible + Data.ShapeCoerce DomainDriven.Persistance.Class DomainDriven.Persistance.ForgetfulInMemory DomainDriven.Persistance.Postgres @@ -59,6 +59,7 @@ library NamedFieldPuns NoImplicitPrelude OverloadedLabels + AllowAmbiguousTypes OverloadedStrings PolyKinds RankNTypes @@ -71,7 +72,7 @@ library TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -Wno-missing-import-lists build-depends: aeson , base @@ -123,6 +124,7 @@ test-suite domaindriven-core-test NamedFieldPuns NoImplicitPrelude OverloadedLabels + AllowAmbiguousTypes OverloadedStrings PolyKinds RankNTypes @@ -135,7 +137,7 @@ test-suite domaindriven-core-test TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -threaded -rtsopts -with-rtsopts=-N -Wall + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -Wno-missing-import-lists -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: aeson , base diff --git a/domaindriven-core/package.yaml b/domaindriven-core/package.yaml index 9d251cd..5462592 100644 --- a/domaindriven-core/package.yaml +++ b/domaindriven-core/package.yaml @@ -45,6 +45,7 @@ default-extensions: - NamedFieldPuns - NoImplicitPrelude - OverloadedLabels +- AllowAmbiguousTypes - OverloadedStrings - PolyKinds - RankNTypes @@ -70,6 +71,7 @@ ghc-options: - -Wincomplete-record-updates - -Wincomplete-patterns - -Wunused-packages +- -Wno-missing-import-lists library: source-dirs: src diff --git a/domaindriven-core/src/Data/ShapeCoercible.hs b/domaindriven-core/src/Data/ShapeCoerce.hs similarity index 100% rename from domaindriven-core/src/Data/ShapeCoercible.hs rename to domaindriven-core/src/Data/ShapeCoerce.hs diff --git a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal index 1f90aea..48b02f0 100644 --- a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal +++ b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal @@ -63,13 +63,15 @@ executable effectful-example TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wno-unused-packages -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wno-unused-packages -fplugin=Effectful.Plugin -threaded -rtsopts -with-rtsopts=-N build-depends: aeson , base , domaindriven-core , domaindriven-effectful , effectful + , effectful-core + , effectful-plugin , servant , servant-server , warp diff --git a/domaindriven-effectful-examples/package.yaml b/domaindriven-effectful-examples/package.yaml index ab33e4f..ce65054 100644 --- a/domaindriven-effectful-examples/package.yaml +++ b/domaindriven-effectful-examples/package.yaml @@ -17,6 +17,8 @@ description: Examples demonstrating the Effectful-based domaindriven lib dependencies: - base +- effectful-core +- effectful-plugin default-extensions: - BlockArguments @@ -64,6 +66,7 @@ ghc-options: - -Wredundant-constraints - -Wincomplete-patterns - -Wno-unused-packages +- -fplugin=Effectful.Plugin executables: effectful-example: diff --git a/domaindriven-effectful-examples/simple-named/Main.hs b/domaindriven-effectful-examples/simple-named/Main.hs new file mode 100644 index 0000000..851cef0 --- /dev/null +++ b/domaindriven-effectful-examples/simple-named/Main.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Main where + +import Control.Monad (when) +import Data.Aeson +import DomainDriven.Effectful +import DomainDriven.Effectful.Interpreter.InMemory +import DomainDriven.FieldNameAsPath +import DomainDriven.Persistance.Class (NoIndex (..), Stored (..)) +import DomainDriven.Persistance.ForgetfulInMemory (ForgetfulInMemory, createForgetful) +import Effectful hiding ((:>)) +import Effectful qualified +import Effectful.Error.Static +import Network.Wai.Handler.Warp (run) +import Servant hiding (throwError) +import Servant qualified +import Servant.API.Generic +import Servant.Server.Generic (AsServerT) +import Prelude + +-------------------------------------------------------------------------------- +-- 1. Define the model +-------------------------------------------------------------------------------- +type CounterModel = Int + +-------------------------------------------------------------------------------- +-- 2. Define events and how to apply them +-------------------------------------------------------------------------------- +data CounterEvent + = Increase + | Decrease + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +applyEvent :: CounterModel -> Stored CounterEvent -> CounterModel +applyEvent i (Stored ev _ _) = case ev of + Increase -> i + 1 + Decrease -> i - 1 + +type CounterDomain = Domain CounterModel CounterEvent NoIndex + +-------------------------------------------------------------------------------- +-- 3. Define the Servant API +-------------------------------------------------------------------------------- +data CounterAPI mode = CounterAPI + { get :: mode :- Get '[JSON] Int + , increase :: mode :- "increase" :> Post '[JSON] Int + , decrease :: mode :- "decrease" :> Post '[JSON] Int + } + deriving (Generic, ApiTagFromLabel) + +-------------------------------------------------------------------------------- +-- 4. Implement the server handlers using Effectful effects +-------------------------------------------------------------------------------- + +-- | Counter handlers using Effectful effects +counterServer + :: ( Projection CounterDomain Effectful.:> es + , Aggregate CounterDomain Effectful.:> es + , Error ServerError Effectful.:> es + ) + => CounterAPI (AsServerT (Eff es)) + +counterServer = + CounterAPI + { get = getModel + , increase = runTransaction do + pure (id, [Increase]) + , decrease = runTransaction do + m <- getModel + when (id m <= 0) + . throwError + $ err422{errBody = "Counter cannot go below zero"} + pure (id, [Decrease]) + } + +counterServer' + :: ( Projection CounterDomain Effectful.:> es + , Aggregate CounterDomain Effectful.:> es + , Error ServerError Effectful.:> es + ) + => ServerT (FieldNameAsPathApi CounterAPI) (Eff es) +counterServer' = FieldNameAsPathServer counterServer + +-------------------------------------------------------------------------------- +-- 5. Wire up the server with effect interpreters +-------------------------------------------------------------------------------- + +mkCounterServer' :: ForgetfulInMemory CounterModel NoIndex CounterEvent -> Application +mkCounterServer' backend = + serveWithContextT + (Proxy @(FieldNameAsPathApi CounterAPI)) + EmptyContext + runEffects + counterServer' + where + -- Helper to run effects and convert to Handler + runEffects + :: Eff + '[ Projection CounterDomain + , Aggregate CounterDomain + , Error ServerError + , IOE + ] + a + -> Handler a + runEffects m = do + a <- + liftIO + . runEff + . runErrorNoCallStack @ServerError + . runAggregateInMemory backend + $ runProjectionInMemory backend m + either Servant.throwError pure a + + +main :: IO () +main = do + let port = 7878 + putStrLn $ "Running Effectful counter on port " <> show port + + -- Initialize the in-memory backend + backend <- createForgetful @NoIndex applyEvent 0 + + -- Create and run the application + let app = mkCounterServer' backend + + run port app + diff --git a/domaindriven-effectful-examples/simple/Main.hs b/domaindriven-effectful-examples/simple/Main.hs index cc200fd..eaad4fe 100644 --- a/domaindriven-effectful-examples/simple/Main.hs +++ b/domaindriven-effectful-examples/simple/Main.hs @@ -9,7 +9,6 @@ import Control.Monad (when) import Data.Aeson import DomainDriven.Effectful import DomainDriven.Effectful.Interpreter.InMemory -import DomainDriven.FieldNameAsPath import DomainDriven.Persistance.Class (NoIndex (..), Stored (..)) import DomainDriven.Persistance.ForgetfulInMemory (ForgetfulInMemory, createForgetful) import Effectful hiding ((:>)) @@ -25,24 +24,26 @@ import Prelude -------------------------------------------------------------------------------- -- 1. Define the model -------------------------------------------------------------------------------- -newtype CounterModel = CounterModel - { getCounter :: Int - } - deriving (Show, Eq, Generic) +type CounterModel = Int -------------------------------------------------------------------------------- --- 2. Define events and how to apply them +-- 2. Define events -------------------------------------------------------------------------------- data CounterEvent = Increase | Decrease deriving (Show, Eq, Generic, ToJSON, FromJSON) + +-------------------------------------------------------------------------------- +-- 2. Define event handler +-------------------------------------------------------------------------------- applyEvent :: CounterModel -> Stored CounterEvent -> CounterModel -applyEvent (CounterModel i) (Stored ev _ _) = CounterModel $ case ev of +applyEvent i (Stored ev _ _) = case ev of Increase -> i + 1 Decrease -> i - 1 +-- Define the domain, used to cary the type constraints type CounterDomain = Domain CounterModel CounterEvent NoIndex -------------------------------------------------------------------------------- @@ -53,7 +54,7 @@ data CounterAPI mode = CounterAPI , increase :: mode :- "increase" :> Post '[JSON] Int , decrease :: mode :- "decrease" :> Post '[JSON] Int } - deriving (Generic, ApiTagFromLabel) + deriving (Generic) -------------------------------------------------------------------------------- -- 4. Implement the server handlers using Effectful effects @@ -69,54 +70,19 @@ counterServer counterServer = CounterAPI - { get = getCounter <$> getModel @CounterDomain - , increase = runTransaction @CounterDomain NoIndex do - pure (getCounter, [Increase]) - , decrease = runTransaction @CounterDomain NoIndex do - m <- getModel @CounterDomain - when (getCounter m <= 0) + { get = getModel + , increase = runTransaction do + pure (id, [Increase]) + , decrease = runTransaction do + m <- getModel + when (id m <= 0) . throwError $ err422{errBody = "Counter cannot go below zero"} - pure (getCounter, [Decrease]) + pure (id, [Decrease]) } -counterServer' - :: ( Projection CounterDomain Effectful.:> es - , Aggregate CounterDomain Effectful.:> es - , Error ServerError Effectful.:> es - ) - => ServerT (FieldNameAsPathApi CounterAPI) (Eff es) -counterServer' = FieldNameAsPathServer counterServer - --- -- | Create the counter server with effect interpreters -mkCounterServer' :: ForgetfulInMemory CounterModel NoIndex CounterEvent -> Application -mkCounterServer' backend = - serveWithContextT - (Proxy @(FieldNameAsPathApi CounterAPI)) - EmptyContext - runEffects - counterServer' - where - -- Helper to run effects and convert to Handler - runEffects - :: Eff - '[ Projection CounterDomain - , Aggregate CounterDomain - , Error ServerError - , IOE - ] - a - -> Handler a - runEffects m = do - a <- - liftIO - . runEff - . runErrorNoCallStack @ServerError - . runAggregateInMemory backend - $ runProjectionInMemory backend NoIndex m - either Servant.throwError pure a -------------------------------------------------------------------------------- -- 5. Wire up the server with effect interpreters @@ -143,7 +109,7 @@ mkCounterServer backend = . runEff . runErrorNoCallStack @ServerError . runAggregateInMemory backend - $ runProjectionInMemory backend NoIndex m + $ runProjectionInMemory backend m either Servant.throwError pure a main :: IO () @@ -152,9 +118,7 @@ main = do putStrLn $ "Running Effectful counter on port " <> show port -- Initialize the in-memory backend - backend <- createForgetful @NoIndex applyEvent (CounterModel 0) + backend <- createForgetful @NoIndex applyEvent 0 -- Create and run the application - let app = mkCounterServer' backend - - run port app + run port $ mkCounterServer backend diff --git a/domaindriven-effectful/domaindriven-effectful.cabal b/domaindriven-effectful/domaindriven-effectful.cabal index 02b9d89..7539bbb 100644 --- a/domaindriven-effectful/domaindriven-effectful.cabal +++ b/domaindriven-effectful/domaindriven-effectful.cabal @@ -71,13 +71,14 @@ library TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wunused-packages + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -Wno-missing-import-lists build-depends: aeson , base , bytestring , domaindriven-core , effectful + , effectful-th , generics-sop , hashable , openapi3 diff --git a/domaindriven-effectful/package.yaml b/domaindriven-effectful/package.yaml index 3204384..7dcf22e 100644 --- a/domaindriven-effectful/package.yaml +++ b/domaindriven-effectful/package.yaml @@ -22,6 +22,7 @@ description: Please see the README on GitHub at (Eff es @@ -21,17 +24,31 @@ data Aggregate (domain :: Type) :: Effect where type instance DispatchOf (Aggregate domain) = 'Dynamic --- | Run a synchronous transaction while holding a lock on the aggregate --- The returnd value is a projection of the model after the events have been applied. +$(makeEffect ''Aggregate) + runTransaction :: forall domain es a . Aggregate domain :> es - => DomainIndex domain - -> ( Eff - es - ( DomainModel domain -> a - , [DomainEvent domain] - ) - ) - -> Eff es a -runTransaction idx cmd = send (RunTransaction @domain idx cmd) + => DomainIndex domain ~ NoIndex + => ( Eff + es + ( DomainModel domain -> a + , [DomainEvent domain] + ) + ) + -> Eff es a +runTransaction = runTransactionI NoIndex +-- | Run a synchronous transaction while holding a lock on the aggregate +-- The returnd value is a projection of the model after the events have been applied. +-- runTransactionI +-- :: forall domain es a +-- . Aggregate domain :> es +-- => DomainIndex domain +-- -> ( Eff +-- es +-- ( DomainModel domain -> a +-- , [DomainEvent domain] +-- ) +-- ) +-- -> Eff es a +-- runTransactionI idx cmd = send (RunTransactionI @domain idx cmd) diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs index b79996a..908a8a5 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs @@ -24,12 +24,11 @@ runProjectionInMemory :: forall domain es a . ( Hashable (DomainIndex domain), IOE :> es) => ForgetfulInMemory (DomainModel domain) (DomainIndex domain) (DomainEvent domain) - -> DomainIndex domain -> Eff (Projection domain : es) a -> Eff es a -runProjectionInMemory backend idx = interpret $ \_ -> \case - GetModel -> liftIO $ P.getModel backend idx - GetEventList -> liftIO $ P.getEventList backend idx +runProjectionInMemory backend = interpret $ \_ -> \case + GetModelI idx -> liftIO $ P.getModel backend idx + GetEventListI idx -> liftIO $ P.getEventList backend idx -- | Run the Aggregate effect using an in-memory backend (new domain API) runAggregateInMemory @@ -41,7 +40,7 @@ runAggregateInMemory -> Eff (Aggregate domain : es) a -> Eff es a runAggregateInMemory backend = interpret $ \env -> \case - RunTransaction idx cmd -> do + RunTransactionI idx cmd -> do localSeqUnlift env $ \unlift -> do (model', _, returnFun) <- P.transactionalUpdate backend idx $ unlift cmd diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs index 34b42c9..b112408 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs @@ -2,34 +2,41 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} module DomainDriven.Effectful.Projection where -import Data.Kind (Type) import DomainDriven.Effectful.Domain -import DomainDriven.Persistance.Class (Stored) +import DomainDriven.Persistance.Class (Stored, NoIndex(..)) +import Data.Type.Equality import Effectful -import Effectful.Dispatch.Dynamic +import Effectful.TH -- | The new Projection effect with a single domain parameter -- We use a proxy to carry the domain type explicitly -data Projection (domain :: Type) :: Effect where - GetModel :: Projection domain m (DomainModel domain) - GetEventList :: Projection domain m [Stored (DomainEvent domain)] +data Projection domain :: Effect where + GetModelI :: DomainIndex domain -> Projection domain m (DomainModel domain) + GetEventListI :: DomainIndex domain -> Projection domain m [Stored (DomainEvent domain)] +-- GetEventStream :: Projection domain m (Stream m (Stored (DomainEvent domain))) type instance DispatchOf (Projection domain) = 'Dynamic --- | Get the model (new domain-based API) +$(makeEffect ''Projection) + getModel :: forall domain es - . Projection domain :> es + . (DomainIndex domain ~ NoIndex + , Projection domain :> es + ) => Eff es (DomainModel domain) -getModel = send (GetModel @domain) +getModel = getModelI NoIndex -- | Get a list of all the events used to create the model (new domain-based API) getEventList :: forall domain es - . Projection domain :> es + . (DomainIndex domain ~ NoIndex + , Projection domain :> es + ) => Eff es [Stored (DomainEvent domain)] -getEventList = send (GetEventList @domain) +getEventList = getEventListI NoIndex From e232cb01e238cfa9f87dc2c4be24975c70e6ef07 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Sat, 13 Sep 2025 11:14:10 +0200 Subject: [PATCH 23/50] Make it compile and remove old domaindriven version --- .claude/settings.json | 13 + .../domaindriven-effectful.cabal | 6 +- domaindriven-effectful/package.yaml | 5 +- .../Effectful/Interpreter/Postgres.hs | 9 +- .../src/DomainDriven/Effectful/Projection.hs | 6 +- .../domaindriven-examples.cabal | 122 ------- domaindriven-examples/hierarchical/Main.hs | 139 -------- domaindriven-examples/package.yaml | 93 ----- domaindriven-examples/simple/Main.hs | 82 ----- domaindriven/ChangeLog.md | 5 - domaindriven/README.md | 128 ------- domaindriven/domaindriven.cabal | 92 ----- domaindriven/package.yaml | 113 ------ domaindriven/src/DomainDriven.hs | 49 --- domaindriven/src/DomainDriven/Server/Api.hs | 221 ------------ .../DomainDriven/Server/DomainDrivenApi.hs | 321 ------------------ .../Server/Helper/GenericRecord.hs | 22 -- .../src/DomainDriven/Server/MapModel.hs | 242 ------------- .../src/DomainDriven/Server/Server.hs | 301 ---------------- .../src/Servant/Auth/Internal/ThrowAll/SOP.hs | 16 - domaindriven/test/Spec.hs | 1 - stack.yaml | 2 - 22 files changed, 29 insertions(+), 1959 deletions(-) create mode 100644 .claude/settings.json delete mode 100644 domaindriven-examples/domaindriven-examples.cabal delete mode 100644 domaindriven-examples/hierarchical/Main.hs delete mode 100644 domaindriven-examples/package.yaml delete mode 100644 domaindriven-examples/simple/Main.hs delete mode 100644 domaindriven/ChangeLog.md delete mode 100644 domaindriven/README.md delete mode 100644 domaindriven/domaindriven.cabal delete mode 100644 domaindriven/package.yaml delete mode 100644 domaindriven/src/DomainDriven.hs delete mode 100644 domaindriven/src/DomainDriven/Server/Api.hs delete mode 100644 domaindriven/src/DomainDriven/Server/DomainDrivenApi.hs delete mode 100644 domaindriven/src/DomainDriven/Server/Helper/GenericRecord.hs delete mode 100644 domaindriven/src/DomainDriven/Server/MapModel.hs delete mode 100644 domaindriven/src/DomainDriven/Server/Server.hs delete mode 100644 domaindriven/src/Servant/Auth/Internal/ThrowAll/SOP.hs delete mode 100644 domaindriven/test/Spec.hs diff --git a/.claude/settings.json b/.claude/settings.json new file mode 100644 index 0000000..6b3e464 --- /dev/null +++ b/.claude/settings.json @@ -0,0 +1,13 @@ +{ + "hooks": { + "Stop": [ + { + "matcher": "", + "hooks": [ + ] + } + + ], + "PostToolUse": [ ] + } +} diff --git a/domaindriven-effectful/domaindriven-effectful.cabal b/domaindriven-effectful/domaindriven-effectful.cabal index 7539bbb..e8fe5af 100644 --- a/domaindriven-effectful/domaindriven-effectful.cabal +++ b/domaindriven-effectful/domaindriven-effectful.cabal @@ -59,6 +59,7 @@ library NamedFieldPuns NoImplicitPrelude OverloadedLabels + AllowAmbiguousTypes OverloadedStrings PolyKinds RankNTypes @@ -71,13 +72,14 @@ library TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -Wno-missing-import-lists + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -Wno-missing-import-lists -fplugin=Effectful.Plugin build-depends: aeson , base , bytestring , domaindriven-core - , effectful + , effectful-core + , effectful-plugin , effectful-th , generics-sop , hashable diff --git a/domaindriven-effectful/package.yaml b/domaindriven-effectful/package.yaml index 7dcf22e..6752e16 100644 --- a/domaindriven-effectful/package.yaml +++ b/domaindriven-effectful/package.yaml @@ -21,7 +21,8 @@ description: Please see the README on GitHub at PostgresEvent (DomainModel domain) (DomainIndex domain) (DomainEvent domain) - -> DomainIndex domain -> Eff (Projection domain : es) a -> Eff es a -runProjectionPostgres backend idx = interpret $ \_ -> \case - GetModel -> liftIO $ P.getModel backend idx - GetEventList -> liftIO $ P.getEventList backend idx +runProjectionPostgres backend = interpret $ \_ -> \case + GetModelI idx -> liftIO $ P.getModel backend idx + GetEventListI idx -> liftIO $ P.getEventList backend idx -- | Run the Aggregate effect using an in-memory backend (new domain API) runAggregateInMemory @@ -51,6 +50,6 @@ runAggregateInMemory -> Eff (Aggregate domain : es) a -> Eff es a runAggregateInMemory backend = interpret $ \env -> \case - RunTransaction idx cmd -> do + RunTransactionI idx cmd -> do localSeqUnlift env $ \unlift -> P.runCmd backend idx $ unlift cmd diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs index b112408..b43150b 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs @@ -15,8 +15,10 @@ import Effectful.TH -- | The new Projection effect with a single domain parameter -- We use a proxy to carry the domain type explicitly data Projection domain :: Effect where - GetModelI :: DomainIndex domain -> Projection domain m (DomainModel domain) - GetEventListI :: DomainIndex domain -> Projection domain m [Stored (DomainEvent domain)] + GetModelI :: DomainIndex domain + -> Projection domain m (DomainModel domain) + GetEventListI :: DomainIndex domain + -> Projection domain m [Stored (DomainEvent domain)] -- GetEventStream :: Projection domain m (Stream m (Stored (DomainEvent domain))) type instance DispatchOf (Projection domain) = 'Dynamic diff --git a/domaindriven-examples/domaindriven-examples.cabal b/domaindriven-examples/domaindriven-examples.cabal deleted file mode 100644 index 7ae79b4..0000000 --- a/domaindriven-examples/domaindriven-examples.cabal +++ /dev/null @@ -1,122 +0,0 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.38.1. --- --- see: https://github.com/sol/hpack - -name: domaindriven-examples -version: 0.5.0 -synopsis: Batteries included event sourcing and CQRS -description: Please see the README on GitHub at -category: Web -homepage: https://github.com/tommyengstrom/domaindriven#readme -bug-reports: https://github.com/tommyengstrom/domaindriven/issues -author: Tommy Engström -maintainer: tommy@tommyengstrom.com -copyright: 2022 Tommy Engström -license: BSD3 -build-type: Simple - -source-repository head - type: git - location: https://github.com/tommyengstrom/domaindriven - -executable hierarchical-example - main-is: Main.hs - other-modules: - Paths_domaindriven_examples - hs-source-dirs: - hierarchical - default-extensions: - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveFunctor - DeriveGeneric - DeriveTraversable - DerivingStrategies - DuplicateRecordFields - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NoImplicitPrelude - OverloadedLabels - OverloadedStrings - PolyKinds - RankNTypes - ScopedTypeVariables - ImportQualifiedPost - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilyDependencies - TypeOperators - TypeSynonymInstances - ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -threaded -rtsopts -with-rtsopts=-N - build-depends: - aeson - , base - , domaindriven - , domaindriven-core - , generic-lens - , microlens - , servant-server - , warp - default-language: Haskell2010 - -executable simple-example - main-is: Main.hs - other-modules: - Paths_domaindriven_examples - hs-source-dirs: - simple - default-extensions: - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveFunctor - DeriveGeneric - DeriveTraversable - DerivingStrategies - DuplicateRecordFields - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NoImplicitPrelude - OverloadedLabels - OverloadedStrings - PolyKinds - RankNTypes - ScopedTypeVariables - ImportQualifiedPost - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilyDependencies - TypeOperators - TypeSynonymInstances - ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -threaded -rtsopts -with-rtsopts=-N - build-depends: - aeson - , base - , domaindriven - , domaindriven-core - , servant-server - , warp - default-language: Haskell2010 diff --git a/domaindriven-examples/hierarchical/Main.hs b/domaindriven-examples/hierarchical/Main.hs deleted file mode 100644 index 1228678..0000000 --- a/domaindriven-examples/hierarchical/Main.hs +++ /dev/null @@ -1,139 +0,0 @@ -module Main where - -import Data.Aeson -import Data.Generics.Labels () -import DomainDriven hiding (applyEvent) -import DomainDriven.Persistance.ForgetfulInMemory (createForgetful) - -import GHC.Generics (Generic) -import Lens.Micro -import Network.Wai.Handler.Warp (run) -import Servant -import Servant.Server.Generic -import Prelude - --------------------------------------------------------------------------------- --- 1. Define the model --------------------------------------------------------------------------------- - --- | This does nothing interesting, only carries the sub-models. -data FullModel = FullModel - { numberModel :: NumberModel - , textModel :: TextModel - } - deriving (Show, Eq, Generic) - -newtype NumberModel = NumberModel {getNumber :: Int} - deriving (Show, Eq, Generic) - -newtype TextModel = TextModel {getText :: String} - deriving (Show, Eq, Generic) - --------------------------------------------------------------------------------- --- 2. Define events and how to apply them --------------------------------------------------------------------------------- -data FullEvent - = NumberEvent NumberEvent - | TextEvent TextEvent - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -data NumberEvent - = SetNumber Int - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -data TextEvent - = SetText String - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -applyEvent :: FullModel -> Stored FullEvent -> FullModel -applyEvent m (Stored ev _ _) = case ev of - NumberEvent ev' -> m & #numberModel %~ (`applyNumberEvent` ev') - TextEvent ev' -> m & #textModel %~ (`applyTextEvent` ev') - -applyNumberEvent :: NumberModel -> NumberEvent -> NumberModel -applyNumberEvent _ ev = case ev of - SetNumber i -> NumberModel i - -applyTextEvent :: TextModel -> TextEvent -> TextModel -applyTextEvent _ ev = case ev of - SetText t -> TextModel t - --------------------------------------------------------------------------------- --- 3. Define the API, i.e. the commands and queries --- If you want to use different model and/or event then these needs to be --- parameters of all the APIs. --------------------------------------------------------------------------------- -data NumberApi model event mode = NumberApi - { set :: mode :- ReqBody '[JSON] Int :> Cmd model event Int - , get :: mode :- Query model Int - } - deriving (Generic, ApiTagFromLabel) - -data TextApi model event mode = TextApi - { set :: mode :- ReqBody '[JSON] String :> Cmd model event String - , get :: mode :- Query model String - } - deriving (Generic, ApiTagFromLabel) - -data FullApi model event mode = FullApi - { number :: mode :- DomainDrivenApi NumberApi model event - , text :: mode :- DomainDrivenApi TextApi model event - } - deriving (Generic, ApiTagFromLabel) - --- 3. Implement the endpoints - -numberServer :: Monad m => NumberApi NumberModel NumberEvent (AsServerT m) -numberServer = - NumberApi - { set = \i -> Cmd $ \_ -> pure (getNumber, [SetNumber i]) - , get = Query (pure . getNumber) - } - -textServer :: Monad m => TextApi TextModel TextEvent (AsServerT m) -textServer = - TextApi - { set = \t -> Cmd $ \_ -> pure (getText, [SetText t]) - , get = Query (pure . getText) - } - -fullServer :: Monad m => FullApi FullModel FullEvent (AsServerT m) -fullServer = - FullApi - { number = - mapModel (^. #numberModel) - . mapEvent NumberEvent - $ DomainDrivenServer numberServer - , text = - mapModel (^. #textModel) - . mapEvent TextEvent - $ DomainDrivenServer textServer - } - -fullServer' - :: Monad m => ServerT (DomainDrivenApi FullApi FullModel FullEvent) m -fullServer' = DomainDrivenServer fullServer - -app - :: ( Model p ~ FullModel - , Event p ~ FullEvent - , Index p ~ NoIndex - , WriteModel p - ) - => p - -> Application -app p = - serveWithContext - (Proxy @(DomainDrivenApi FullApi FullModel FullEvent)) - (ReadPersistence p :. WritePersistence p :. EmptyContext) - fullServer' - -main :: IO () -main = do - let port = 7878 - putStrLn $ "Running on port " <> show port - p <- - createForgetful - applyEvent - (FullModel (NumberModel 0) (TextModel "")) - run port (app p) diff --git a/domaindriven-examples/package.yaml b/domaindriven-examples/package.yaml deleted file mode 100644 index 960ea8c..0000000 --- a/domaindriven-examples/package.yaml +++ /dev/null @@ -1,93 +0,0 @@ -name: domaindriven-examples -version: 0.5.0 -github: "tommyengstrom/domaindriven" -license: BSD3 -author: "Tommy Engström" -maintainer: "tommy@tommyengstrom.com" -copyright: "2022 Tommy Engström" - -extra-source-files: [] - -# Metadata used when publishing your package -synopsis: Batteries included event sourcing and CQRS -category: Web - -# To avoid duplicated efforts in documentation and dealing with the -# complications of embedding Haddock markup inside cabal files, it is -# common to point users to the README.md file. -description: Please see the README on GitHub at - -dependencies: -- aeson -- base -- domaindriven-core -- domaindriven -- servant-server -- warp - - -default-extensions: -- ConstraintKinds -- DataKinds -- DeriveAnyClass -- DeriveFunctor -- DeriveGeneric -- DeriveTraversable -- DerivingStrategies -- DuplicateRecordFields -- FlexibleContexts -- FlexibleInstances -- FunctionalDependencies -- GADTs -- GeneralizedNewtypeDeriving -- ImportQualifiedPost -- LambdaCase -- MultiParamTypeClasses -- MultiWayIf -- NamedFieldPuns -- NoImplicitPrelude -- OverloadedLabels -- OverloadedStrings -- PolyKinds -- RankNTypes -- ScopedTypeVariables -- ImportQualifiedPost -- StandaloneDeriving -- TupleSections -- TypeApplications -- TypeFamilyDependencies -- TypeOperators -- TypeSynonymInstances -- ViewPatterns - -ghc-options: -- -Wall -- -Werror -- -Wcompat -- -Widentities -- -Wincomplete-record-updates -- -Wincomplete-uni-patterns -- -Wpartial-fields -- -Wredundant-constraints -- -Wincomplete-record-updates -- -Wincomplete-patterns -- -Wunused-packages - -executables: - simple-example: - main: Main.hs - source-dirs: simple - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - hierarchical-example: - main: Main.hs - source-dirs: hierarchical - dependencies: - - generic-lens - - microlens - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N diff --git a/domaindriven-examples/simple/Main.hs b/domaindriven-examples/simple/Main.hs deleted file mode 100644 index 288792f..0000000 --- a/domaindriven-examples/simple/Main.hs +++ /dev/null @@ -1,82 +0,0 @@ -module Main where - -import Data.Aeson -import DomainDriven hiding (applyEvent) -import DomainDriven.Persistance.ForgetfulInMemory (createForgetful) -import GHC.Generics (Generic) -import Network.Wai.Handler.Warp (run) -import Servant -import Servant.Server.Generic -import Prelude - --------------------------------------------------------------------------------- --- 1. Define the model --------------------------------------------------------------------------------- -newtype CounterModel = CounterModel {getCounter :: Int} - deriving (Show, Eq, Generic) - --------------------------------------------------------------------------------- --- 2. Define events and how to apply them --------------------------------------------------------------------------------- -data CounterEvent - = Increase - | Decrease - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -applyEvent :: CounterModel -> Stored CounterEvent -> CounterModel -applyEvent (CounterModel i) (Stored ev _ _) = CounterModel $ case ev of - Increase -> i + 1 - Decrease -> i - 1 - --------------------------------------------------------------------------------- --- 3. Define the API, i.e. the commands and queries --------------------------------------------------------------------------------- -data CounterApi model event mode = CounterApi - { current :: mode :- Query model Int - , increase :: mode :- Cmd model event Int - , decrease :: mode :- Cmd model event Int - } - deriving (Generic) - --- 3. Implement the endpoints -counterServers :: forall m. Monad m => CounterApi CounterModel CounterEvent (AsServerT m) -counterServers = - CounterApi - { current = Query (pure . getCounter) - , increase = Cmd $ \_ -> pure (getCounter, [Increase]) - , decrease = Cmd $ \_ -> pure (getCounter, [Decrease]) - } - --- 4. Define the final API type using `DomainDrivenApi`, which uses the labels of the --- record to add a path piece to the final endpoints. - -type ServantCounterApi = DomainDrivenApi CounterApi CounterModel CounterEvent - --- 5. Define the server. --- The `HasServer` instance for `DomainDrivenApi` with covert it into a `DomainDrivenServer` -counterServer :: forall m. Monad m => ServerT ServantCounterApi m -counterServer = DomainDrivenServer counterServers - --- FIXME: This should be the default implementation imo -instance ApiTagFromLabel CounterApi where - apiTagFromLabel = id - -mkWaiApp - :: Model p ~ CounterModel - => Event p ~ CounterEvent - => Index p ~ NoIndex - => WriteModel p - => p - -> Application -mkWaiApp p = - serveWithContext - (Proxy @ServantCounterApi) - (ReadPersistence p :. WritePersistence p :. EmptyContext) - counterServer - -main :: IO () -main = do - let port = 7878 - putStrLn $ "Running on port " <> show port - p <- createForgetful @NoIndex applyEvent (CounterModel 0) - run port (mkWaiApp p) diff --git a/domaindriven/ChangeLog.md b/domaindriven/ChangeLog.md deleted file mode 100644 index bbe5838..0000000 --- a/domaindriven/ChangeLog.md +++ /dev/null @@ -1,5 +0,0 @@ -# Changelog for domaindriven - -## 0.5.0 - -First release published on hackage. diff --git a/domaindriven/README.md b/domaindriven/README.md deleted file mode 100644 index 2af6acc..0000000 --- a/domaindriven/README.md +++ /dev/null @@ -1,128 +0,0 @@ -# DomainDriven - -DomainDriven is a batteries included synchronous event sourcing and CQRS library. The goal of this library is to allow you to implement DDD principles without focusing on the boilerplate. - -It uses `Template Haskell` we generate a Servant server from the specification and we aim to keep the specification as succinct as we can. - -## The idea - -- Use a GADT to specify the actions, what will be translated into `GET`s and `POST`s. -- Make each event update run in a transaction, thereby avoiding the eventual consistency issues commonly associated with event sourcing. - -## How it works - -In order to implement a model in `domaindriven` you have to define: -- The model (current state) -- The events -- How to update the model when new events come in -- The actions (queries and commands) -- How to handle actions - -### Model - -The model is the current state of the system. This is what you normally would keep in a database, but as this is an event sourced system the state is not fundamental as it can be recalculated. - -Currently all implemented persistence strategies all keep the state in memory. - -### Events - -Events are things that happened in the past. The event you define represent all the changes that can occur in the system. - -Events should be specified in past tens. -```haskell - -data Event - = IncreasedCounter - | DecreasedCounter -``` - -### Event handler - -The model is calculated as a fold over the stream of events. As events happened in the past we can never refuse to handle them. This means the event handler is simply: - -``` haskell -applyEvent :: Model -> Stored Event -> Model -``` - -where Stored is defined as: -``` haskell -data Stored a = Stored - { storedEvent :: a - , storedTimestamp :: UTCTime - , storedUUID :: UUID - } -``` - -### Commands - -Commands are defined using a GADT with one type parameter representing the return type. For example: - -``` haskell --- Same as: data StorageAction (x :: ParamPart) method a where -data StorageAction :: Action where - GetFile - :: P x "fileId" UUID - -> StorageAction x Query ByteString - AddFile - :: P x "fileContent" ByteString - -> StorageAction Cmd UUID - RemoveFile - :: P x "fileId" UUID - -> StorageAction Cmd () -``` - -### Action handler - -Actions, in contrast to events, are allowed to fail. If an action succeeds we need to return a value of the type specified by the constructor and, if it was a command, a list of events. The action handler do not update the state. - -In addition you may need to make requests, read from disk, or perform other side effects in order to calculate the result. - -`ActionHandler` is defined as: - -``` haskell -type ActionHandler model event m c = - forall method a. c 'ParamType method a -> HandlerType method model event m a -``` - -In practice this means you specify actions as - -```haskell - -data CounterAction x method return where - GetCounter ::CounterAction x Query Int - IncreaseCounter ::CounterAction x Cmd Int - DecreaseCounter ::CounterAction x Cmd Int -``` - -and the corresponding handler as - -```haskell -handleAction :: ActionHandler CounterAction CounterEvent IO a -handleAction = \case - GetCounter -> Query $ pure -- Query is just `model -> IO a` - IncreaseCounter -> Cmd $ \_ -> `model -> IO (model -> a, [CounterEvent])` - pure (id -- return state as is, after the event is applied - , [CounterIncreased]) - DecreaseCounter -> Cmd $ \counter -> do - when (counter < 1) (throwM NegativeNotSupported) - pure (id, [CounterDecreased]) -``` - -A `Query` takes a `model -> m a`, i.e. you get access to the model and the ability to run monadic efficts. `Query`s will be translates into `GET` in the generated API. - -A `Cmd` has the additional ability of emitting events. It takes a `model -> m (model -> a, [event])`. The return value is specified as a function from the updated model to the return type. This way we can, in the Counter example, return the new value after the event handler has run. - - -### Generating the server - - -Now we have defined the core parts of our service. We can now generate the server using the template-haskell function `mkServer`. It takes two arguments: The server config and the name of the GADT representing the actions. E.g. `$(mkServer counterActionConfig ''CounterAction)`. - -The `ServerConfig`, `storeActionConfig` in this example, contains the API options for the for the Action and all it's sub actions, as well as a all parameter names. This can be tenerated with `$(mkServerConfig "counterActionConfig")`, but due to TemplateHaskell's stage restrictions it cannot run in the same file as `mkServer`. - - -### Simple example - -Minimal example can be found in [examples/simple/Main.hs](examples/simple/Main.hs), this uses the model defined in [models/Models/Counter.hs](models/Models/Counter.hs) - - diff --git a/domaindriven/domaindriven.cabal b/domaindriven/domaindriven.cabal deleted file mode 100644 index 995ad36..0000000 --- a/domaindriven/domaindriven.cabal +++ /dev/null @@ -1,92 +0,0 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.38.0. --- --- see: https://github.com/sol/hpack - -name: domaindriven -version: 0.5.0 -synopsis: Batteries included event sourcing and CQRS -description: Please see the README on GitHub at -category: Web -homepage: https://github.com/tommyengstrom/domaindriven#readme -bug-reports: https://github.com/tommyengstrom/domaindriven/issues -author: Tommy Engström -maintainer: tommy@tommyengstrom.com -copyright: 2023 Tommy Engström -license: BSD3 -build-type: Simple -extra-source-files: - README.md - ChangeLog.md - -source-repository head - type: git - location: https://github.com/tommyengstrom/domaindriven - -library - exposed-modules: - DomainDriven - DomainDriven.Server.Api - DomainDriven.Server.DomainDrivenApi - DomainDriven.Server.Helper.GenericRecord - DomainDriven.Server.MapModel - DomainDriven.Server.Server - Servant.Auth.Internal.ThrowAll.SOP - other-modules: - Paths_domaindriven - hs-source-dirs: - src - default-extensions: - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveFunctor - DeriveGeneric - DeriveTraversable - DerivingStrategies - DuplicateRecordFields - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NoImplicitPrelude - OverloadedLabels - OverloadedStrings - PolyKinds - RankNTypes - ScopedTypeVariables - StandaloneDeriving - StrictData - TupleSections - TypeApplications - TypeFamilyDependencies - TypeOperators - TypeSynonymInstances - ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages - build-depends: - aeson - , base - , bytestring - , domaindriven-core - , exceptions - , generics-sop - , mtl - , openapi3 - , optics - , servant - , servant-auth-server - , servant-client-core - , servant-openapi3 - , servant-server - , text - , unliftio - , uuid - default-language: Haskell2010 diff --git a/domaindriven/package.yaml b/domaindriven/package.yaml deleted file mode 100644 index 8c8974f..0000000 --- a/domaindriven/package.yaml +++ /dev/null @@ -1,113 +0,0 @@ -name: domaindriven -version: 0.5.0 -github: "tommyengstrom/domaindriven" -license: BSD3 -author: "Tommy Engström" -maintainer: "tommy@tommyengstrom.com" -copyright: "2023 Tommy Engström" - -extra-source-files: -- README.md -- ChangeLog.md - -# Metadata used when publishing your package -synopsis: Batteries included event sourcing and CQRS -category: Web - -# To avoid duplicated efforts in documentation and dealing with the -# complications of embedding Haddock markup inside cabal files, it is -# common to point users to the README.md file. -description: Please see the README on GitHub at - -dependencies: -- base -- aeson -- domaindriven-core -- exceptions -- generics-sop -- openapi3 -- optics -- servant -- servant-auth-server -- servant-client-core -- servant-openapi3 -- servant-server -- text - - -default-extensions: -- ConstraintKinds -- DataKinds -- DeriveAnyClass -- DeriveFunctor -- DeriveGeneric -- DeriveTraversable -- DerivingStrategies -- DuplicateRecordFields -- FlexibleContexts -- FlexibleInstances -- FunctionalDependencies -- GADTs -- GeneralizedNewtypeDeriving -- ImportQualifiedPost -- LambdaCase -- MultiParamTypeClasses -- MultiWayIf -- NamedFieldPuns -- NoImplicitPrelude -- OverloadedLabels -- OverloadedStrings -- PolyKinds -- RankNTypes -- ScopedTypeVariables -- StandaloneDeriving -- StrictData -- TupleSections -- TypeApplications -- TypeFamilyDependencies -- TypeOperators -- TypeSynonymInstances -- ViewPatterns - -ghc-options: -- -Wall -- -Werror -- -Wcompat -- -Widentities -- -Wincomplete-record-updates -- -Wincomplete-uni-patterns -- -Wpartial-fields -- -Wredundant-constraints -- -Wincomplete-record-updates -- -Wincomplete-patterns -- -Wunused-packages - -library: - source-dirs: src - dependencies: - - bytestring - - mtl - - unliftio - - uuid - -#tests: -# domaindriven-test: -# main: Spec.hs -# source-dirs: -# - test -# ghc-options: -# - -threaded -# - -rtsopts -# - -with-rtsopts=-N -# - -Wall -# dependencies: -# - async -# - domaindriven -# - hspec -# - http-client -# - mtl -# - QuickCheck -# - quickcheck-arbitrary-adt -# - quickcheck-classes -# - servant-client -# - warp diff --git a/domaindriven/src/DomainDriven.hs b/domaindriven/src/DomainDriven.hs deleted file mode 100644 index c5063b1..0000000 --- a/domaindriven/src/DomainDriven.hs +++ /dev/null @@ -1,49 +0,0 @@ -module DomainDriven (module X) where - -import Data.UUID as X (UUID) - -import DomainDriven.Persistance.Class as X - ( ReadModel (..) - , Stored (..) - , WriteModel (..) - , Indexed (..) - , NoIndex (..) - , mkId - , runCmd - ) -import DomainDriven.Server.Api as X - ( CbCmd - , CbQuery - , Cmd - , Query - , CbCmdI - , CbQueryI - , CmdI - , QueryI - , Field (..) - , JsonObject (..) - , NamedField (..) - ) -import DomainDriven.Server.DomainDrivenApi as X - ( ApiTagFromLabel (..) - , DomainDrivenApi - , DomainDrivenServer (..) - ) -import DomainDriven.Server.MapModel as X - ( MapEvent (..) - , MapModel (..) - , MapModelAndEvent (..) - ) -import DomainDriven.Server.Server as X - ( CbCmdServer (..) - , CbQueryServer (..) - , CmdServer (..) - , QueryServer (..) - , CbCmdServerI (..) - , CbQueryServerI (..) - , CmdServerI (..) - , QueryServerI (..) - , ReadPersistence (..) - , WritePersistence (..) - ) -import Generics.SOP.NP as X (NP (..)) diff --git a/domaindriven/src/DomainDriven/Server/Api.hs b/domaindriven/src/DomainDriven/Server/Api.hs deleted file mode 100644 index b3b61a3..0000000 --- a/domaindriven/src/DomainDriven/Server/Api.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} --- got it the wrong way around. this should presumably be domaindriven.servant.api -{-# LANGUAGE UndecidableInstances #-} - -module DomainDriven.Server.Api where - -import Data.Aeson -import Data.Aeson.Key as Key -import Data.Aeson.KeyMap qualified as KeyMap -import Data.Aeson.Types -import Data.Function -import Data.Kind -import Data.OpenApi -import Data.OpenApi.Internal.Schema -import Data.Text qualified as Text -import Data.Typeable -import GHC.TypeLits -import Generics.SOP hiding (fieldName) -import Optics -import Servant.API (JSON, StdMethod (GET, POST), Verb) -import Servant.Client.Core -import Servant.OpenApi -import Prelude - -type Cmd model event a = Cmd' model event (Verb 'POST 200 '[JSON] a) -type CbCmd model event a = CbCmd' model event (Verb 'POST 200 '[JSON] a) -type CbQuery model a = CbQuery' model (Verb 'GET 200 '[JSON] a) -type Query model a = Query' model (Verb 'GET 200 '[JSON] a) - -data Cmd' (model :: Type) (event :: Type) (verb :: Type) -data Query' (model :: Type) (verb :: Type) -data CbQuery' (model :: Type) (verb :: Type) -data CbCmd' (model :: Type) (event :: Type) (verb :: Type) - -type CmdI index model event a = CmdI' index model event (Verb 'POST 200 '[JSON] a) -type CbCmdI index model event a = CbCmdI' index model event (Verb 'POST 200 '[JSON] a) -type CbQueryI index model a = CbQueryI' index model (Verb 'GET 200 '[JSON] a) -type QueryI index model a = QueryI' index model (Verb 'GET 200 '[JSON] a) - -data CmdI' (index :: Type) (model :: Type) (event :: Type) (verb :: Type) -data QueryI' (index :: Type) (model :: Type) (verb :: Type) -data CbQueryI' (index :: Type) (model :: Type) (verb :: Type) -data CbCmdI' (index :: Type) (model :: Type) (event :: Type) (verb :: Type) - -instance HasOpenApi verb => HasOpenApi (Cmd' model event verb) where - toOpenApi _ = toOpenApi $ Proxy @verb -instance HasOpenApi verb => HasOpenApi (CmdI' index model event verb) where - toOpenApi _ = toOpenApi $ Proxy @verb - -instance HasOpenApi verb => HasOpenApi (CbCmd' model event verb) where - toOpenApi _ = toOpenApi $ Proxy @verb -instance HasOpenApi verb => HasOpenApi (CbCmdI' index model event verb) where - toOpenApi _ = toOpenApi $ Proxy @verb - -instance HasOpenApi verb => HasOpenApi (Query' model verb) where - toOpenApi _ = toOpenApi $ Proxy @verb -instance HasOpenApi verb => HasOpenApi (QueryI' index model verb) where - toOpenApi _ = toOpenApi $ Proxy @verb - -instance HasOpenApi verb => HasOpenApi (CbQuery' model verb) where - toOpenApi _ = toOpenApi $ Proxy @verb -instance HasOpenApi verb => HasOpenApi (CbQueryI' index model verb) where - toOpenApi _ = toOpenApi $ Proxy @verb - -data NamedField = NamedField Symbol Type - -type family FieldTypes (fields :: [NamedField]) :: [Type] where - FieldTypes '[] = '[] - FieldTypes ('NamedField _ t ': fields) = t ': FieldTypes fields - -newtype Field a = Field a - -newtype JsonObject (fields :: [NamedField]) = JsonObject (NP Field (FieldTypes fields)) - -class ParseFields (fields :: [NamedField]) where - parseFields :: Object -> Parser (NP Field (FieldTypes fields)) - -class UnparseFields (fields :: [NamedField]) where - unparseFields :: NP Field (FieldTypes fields) -> Object - -instance UnparseFields '[] where - unparseFields Nil = mempty - -instance - ( KnownSymbol name - , ToJSON a - , UnparseFields fields - ) - => UnparseFields ('NamedField name a ': fields) - where - unparseFields (Field a :* fields) = - KeyMap.insert (Key.fromString (symbolVal $ Proxy @name)) (toJSON a) $ - unparseFields @fields fields - -instance ParseFields '[] where - parseFields _ = pure Nil - -instance - (ParseFields fields, FromJSON t, KnownSymbol name) - => ParseFields ('NamedField name (Maybe t) ': fields) - where - parseFields o = do - fields <- parseFields @fields o - t <- o .:? fromString (symbolVal (Proxy @name)) - pure $ Field t :* fields - -instance - {-# OVERLAPPABLE #-} - (ParseFields fields, FromJSON t, KnownSymbol name) - => ParseFields ('NamedField name t ': fields) - where - parseFields o = do - fields <- parseFields @fields o - t <- o .: fromString (symbolVal (Proxy @name)) - pure $ Field t :* fields - -instance ParseFields fields => FromJSON (JsonObject fields) where - parseJSON = withObject "JsonObject" $ \o -> JsonObject <$> parseFields @fields o - -instance ToSchema (JsonObject '[]) where - declareNamedSchema _ = pure . unnamed $ mempty & #type ?~ OpenApiObject - -instance - ( Typeable (JsonObject ('NamedField name t ': fields)) - , ToSchema (JsonObject fields) - , ToSchema t - , KnownSymbol name - ) - => ToSchema (JsonObject ('NamedField name t ': fields)) - where - declareNamedSchema _ = do - NamedSchema _ subSchema <- declareNamedSchema (Proxy @(JsonObject fields)) - let fieldName = Text.pack $ symbolVal (Proxy @name) - fieldSchemaRef <- declareSchemaRef (Proxy @t) - pure . NamedSchema Nothing $ - subSchema - & #properties % at fieldName ?~ fieldSchemaRef - & if isOptional @t - then id - else #required %~ (++ [fieldName]) - -instance UnparseFields fields => ToJSON (JsonObject fields) where - toJSON (JsonObject fields) = Object $ unparseFields @fields fields - -class IsOptional t where - isOptional :: Bool - -instance IsOptional (Maybe t) where - isOptional = True - -instance {-# OVERLAPPABLE #-} IsOptional t where - isOptional = False - - -instance - {-# OVERLAPPING #-} - HasClient m (Verb method status cts ret) - => HasClient m (Cmd' model event (Verb method status cts ret)) - where - type Client m (Cmd' model event (Verb method status cts ret)) = m ret - clientWithRoute pm _ = clientWithRoute pm (Proxy @(Verb method status cts ret)) - hoistClientMonad _ _ f ma = f ma -instance - {-# OVERLAPPING #-} - HasClient m (Verb method status cts ret) - => HasClient m (CmdI' index model event (Verb method status cts ret)) - where - type Client m (CmdI' index model event (Verb method status cts ret)) = m ret - clientWithRoute pm _ = clientWithRoute pm (Proxy @(Verb method status cts ret)) - hoistClientMonad _ _ f ma = f ma - -instance - {-# OVERLAPPING #-} - HasClient m (Verb method status cts ret) - => HasClient m (CbCmd' model event (Verb method status cts ret)) - where - type Client m (CbCmd' model event (Verb method status cts ret)) = m ret - clientWithRoute pm _ = clientWithRoute pm (Proxy @(Verb method status cts ret)) - hoistClientMonad _ _ f ma = f ma -instance - {-# OVERLAPPING #-} - HasClient m (Verb method status cts ret) - => HasClient m (CbCmdI' index model event (Verb method status cts ret)) - where - type Client m (CbCmdI' index model event (Verb method status cts ret)) = m ret - clientWithRoute pm _ = clientWithRoute pm (Proxy @(Verb method status cts ret)) - hoistClientMonad _ _ f ma = f ma - -instance - {-# OVERLAPPING #-} - HasClient m (Verb method status cts ret) - => HasClient m (Query' model (Verb method status cts ret)) - where - type Client m (Query' model (Verb method status cts ret)) = m ret - clientWithRoute pm _ = clientWithRoute pm (Proxy @(Verb method status cts ret)) - hoistClientMonad _ _ f ma = f ma -instance - {-# OVERLAPPING #-} - HasClient m (Verb method status cts ret) - => HasClient m (QueryI' index model (Verb method status cts ret)) - where - type Client m (QueryI' index model (Verb method status cts ret)) = m ret - clientWithRoute pm _ = clientWithRoute pm (Proxy @(Verb method status cts ret)) - hoistClientMonad _ _ f ma = f ma - -instance - {-# OVERLAPPING #-} - HasClient m (Verb method status cts ret) - => HasClient m (CbQuery' model (Verb method status cts ret)) - where - type Client m (CbQuery' model (Verb method status cts ret)) = m ret - clientWithRoute pm _ = clientWithRoute pm (Proxy @(Verb method status cts ret)) - hoistClientMonad _ _ f ma = f ma -instance - {-# OVERLAPPING #-} - HasClient m (Verb method status cts ret) - => HasClient m (CbQueryI' index model (Verb method status cts ret)) - where - type Client m (CbQueryI' index model (Verb method status cts ret)) = m ret - clientWithRoute pm _ = clientWithRoute pm (Proxy @(Verb method status cts ret)) - hoistClientMonad _ _ f ma = f ma diff --git a/domaindriven/src/DomainDriven/Server/DomainDrivenApi.hs b/domaindriven/src/DomainDriven/Server/DomainDrivenApi.hs deleted file mode 100644 index d4bcf62..0000000 --- a/domaindriven/src/DomainDriven/Server/DomainDrivenApi.hs +++ /dev/null @@ -1,321 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE UndecidableInstances #-} - -module DomainDriven.Server.DomainDrivenApi where - -import Data.ByteString.Builder qualified as Builder -import Data.Kind -import Data.OpenApi (OpenApi, prependPath) -import Data.Text qualified as Text -import DomainDriven.Server.Helper.GenericRecord -import GHC.Generics qualified as GHC -import GHC.TypeLits -import Generics.SOP - ( I (..) - , NP (..) - , NS (..) - , SOP (..) - , unSOP - ) -import Generics.SOP.GGP -import Generics.SOP.Type.Metadata -import Servant -import Servant.Auth.Internal.ThrowAll.SOP () -import Servant.Auth.Server.Internal.ThrowAll -import Servant.Client.Core -import Servant.Client.Generic -import Servant.OpenApi -import Servant.Server.Generic -import Servant.Server.Internal.Delayed -import Servant.Server.Internal.Router -import Prelude - -type Api = Type - --- | Wrapper around the data structure containing the API and endpoint definitions. --- The endpoints name in the record will be added to the path. For example: --- ``` --- data CounterAction model event mode = CounterAction --- { increaseWith :: mode :- "something" :> ReqBody '[JSON] Int :> Cmd model event Int --- } --- ``` --- Will result in a Post endpoint with path "something/increaseWith". -data - DomainDrivenApi - (mkApiRecord :: Type -> Type -> Type -> Type) - (model :: Type) - (event :: Type) - -class ApiTagFromLabel (mkApiRecord :: Type -> Type -> Type -> Type) where - apiTagFromLabel :: String -> String - apiTagFromLabel = id - --- | Wrapper around the data structure containing the API and endpoint definitions. --- This is used to carry the expectation of `HasServer` for `DomainDrivenApi`. i.e. --- this is what the `ServerT` type family will produce when given a `DomainDrivenApi`. -newtype - DomainDrivenServer - (mkServerRecord :: Type -> Type -> Type -> Type) - (model :: Type) - (event :: Type) - (m :: Type -> Type) = DomainDrivenServer - { unDomainDrivenServer - :: mkServerRecord model event (AsServerT m) - } - -deriving newtype instance - GHC.Generic (mkServerRecord model event (AsServerT m)) - => GHC.Generic (DomainDrivenServer mkServerRecord model event m) - -class DomainDrivenServerFields (mkApiRecord :: Type -> Type) (m :: Type -> Type) where - recordOfServersFromFields - :: NP I (ServerTs (GenericRecordFields (mkApiRecord AsApi)) m) - -> mkApiRecord (AsServerT m) - recordOfServersToFields - :: mkApiRecord (AsServerT m) - -> NP I (ServerTs (GenericRecordFields (mkApiRecord AsApi)) m) - -instance - ( GHC.Generic (mkApiRecord (AsServerT m)) - , GCode (mkApiRecord (AsServerT m)) - ~ '[ServerTs (GenericRecordFields (mkApiRecord AsApi)) m] - , GFrom (mkApiRecord (AsServerT m)) - , GTo (mkApiRecord (AsServerT m)) - ) - => DomainDrivenServerFields mkApiRecord m - where - recordOfServersFromFields = gto . SOP . Z - recordOfServersToFields x = case unSOP $ gfrom x of - Z servers -> servers - S y -> case y of {} - -class - DomainDrivenApiHasServers - (mkApiRecord :: Type -> Type -> Type -> Type) - (model :: Type) - (event :: Type) - (apis :: [Api]) - (infos :: [FieldInfo]) - (context :: [Type]) - where - type ServerTs apis (m :: Type -> Type) :: [Type] - taggedSumOfRoutes - :: Context context - -> Delayed env (NP I (ServerTs apis Handler)) - -> Router env - hoistTaggedServersWithContext - :: (forall x. m x -> n x) - -> NP I (ServerTs apis m) - -> NP I (ServerTs apis n) - -instance DomainDrivenApiHasServers mkApiRecord model event '[] '[] context where - type ServerTs '[] m = '[] - taggedSumOfRoutes _ _ = StaticRouter mempty mempty - hoistTaggedServersWithContext _ Nil = Nil - -instance - ( HasServer api context - , DomainDrivenApiHasServers mkApiRecord model event apis infos context - , KnownSymbol label - , ApiTagFromLabel mkApiRecord - ) - => DomainDrivenApiHasServers - mkApiRecord - model - event - (api ': apis) - ('FieldInfo label ': infos) - context - where - type ServerTs (api ': apis) m = ServerT api m ': ServerTs apis m - - taggedSumOfRoutes context delayedServers = - choice - ( pathRouter - (Text.pack $ apiTagFromLabel @mkApiRecord $ symbolVal (Proxy @label)) - $ route (Proxy @api) context - $ (\(I server :* _) -> server) <$> delayedServers - ) - ( taggedSumOfRoutes @mkApiRecord @model @event @apis @infos context $ - (\(_ :* servers) -> servers) <$> delayedServers - ) - - hoistTaggedServersWithContext nt (I server :* servers) = - I (hoistServerWithContext (Proxy @api) (Proxy @context) nt server) - :* hoistTaggedServersWithContext @mkApiRecord @model @event @apis @infos @context nt servers - -instance - ( DomainDrivenApiHasServers - mkApiRecord - model - event - (GenericRecordFields (mkApiRecord model event AsApi)) - (GenericRecordFieldInfos (mkApiRecord model event AsApi)) - context - , forall m. DomainDrivenServerFields (mkApiRecord model event) m - ) - => HasServer (DomainDrivenApi mkApiRecord model event) context - where - type - ServerT (DomainDrivenApi mkApiRecord model event) m = - DomainDrivenServer mkApiRecord model event m - - route _ context delayedServer = - taggedSumOfRoutes @mkApiRecord @model @event - @(GenericRecordFields (mkApiRecord model event AsApi)) - @(GenericRecordFieldInfos (mkApiRecord model event AsApi)) - context - (recordOfServersToFields . unDomainDrivenServer <$> delayedServer) - - hoistServerWithContext _ _ nt servers = - DomainDrivenServer - . recordOfServersFromFields - . hoistTaggedServersWithContext @mkApiRecord @model @event - @(GenericRecordFields (mkApiRecord model event AsApi)) - @(GenericRecordFieldInfos (mkApiRecord model event AsApi)) - @context - nt - . recordOfServersToFields - $ unDomainDrivenServer servers - -class - DomainDrivenApiHasOpenApi - (mkApiRecord :: Type -> Type -> Type -> Type) - (apis :: [Api]) - (infos :: [FieldInfo]) - where - domainDrivenApiToOpenApi :: OpenApi - -instance DomainDrivenApiHasOpenApi mkApiRecord '[] '[] where - domainDrivenApiToOpenApi = mempty - -instance - ( KnownSymbol label - , ApiTagFromLabel mkApiRecord - , HasOpenApi api - , DomainDrivenApiHasOpenApi mkApiRecord apis infos - ) - => DomainDrivenApiHasOpenApi mkApiRecord (api ': apis) ('FieldInfo label ': infos) - where - domainDrivenApiToOpenApi = - prependPath - (apiTagFromLabel @mkApiRecord $ symbolVal (Proxy @label)) - (toOpenApi (Proxy @api)) - <> domainDrivenApiToOpenApi @mkApiRecord @apis @infos - -instance - DomainDrivenApiHasOpenApi - mkApiRecord - (GenericRecordFields (mkApiRecord model event AsApi)) - (GenericRecordFieldInfos (mkApiRecord model event AsApi)) - => HasOpenApi (DomainDrivenApi mkApiRecord model event) - where - toOpenApi _ = - domainDrivenApiToOpenApi @mkApiRecord - @(GenericRecordFields (mkApiRecord model event AsApi)) - @(GenericRecordFieldInfos (mkApiRecord model event AsApi)) - -instance - ( GHC.Generic (DomainDrivenServer mkServerRecord model event m) - , GTo (DomainDrivenServer mkServerRecord model event m) - , ThrowAll (SOP I (GCode (DomainDrivenServer mkServerRecord model event m))) - ) - => ThrowAll (DomainDrivenServer mkServerRecord model event m) - where - throwAll = gto . throwAll @(SOP I (GCode (DomainDrivenServer mkServerRecord model event m))) - -class - DomainDrivenApiHasClients - (m :: Type -> Type) - (mkApiRecord :: Type -> Type -> Type -> Type) - (apis :: [Api]) - (infos :: [FieldInfo]) - where - type Clients apis m :: [Type] - clientsWithRoute :: Request -> NP I (Clients apis m) - hoistClientsMonad - :: (forall x. mon x -> mon' x) - -> NP I (Clients apis mon) - -> NP I (Clients apis mon') - -instance DomainDrivenApiHasClients m mkApiRecord '[] '[] where - type Clients '[] m = '[] - clientsWithRoute _ = Nil - hoistClientsMonad _ Nil = Nil - -instance - ( HasClient m api - , DomainDrivenApiHasClients m mkApiRecord apis infos - , KnownSymbol label - , ApiTagFromLabel mkApiRecord - ) - => DomainDrivenApiHasClients m mkApiRecord (api ': apis) ('FieldInfo label ': infos) - where - type Clients (api ': apis) m = Client m api ': Clients apis m - - clientsWithRoute req = - I - ( clientWithRoute - (Proxy @m) - (Proxy @api) - ( appendToPath - (Builder.stringUtf8 $ apiTagFromLabel @mkApiRecord $ symbolVal (Proxy @label)) - req - ) - ) - :* clientsWithRoute @m @mkApiRecord @apis @infos req - hoistClientsMonad nt (I client :* clients) = - I (hoistClientMonad (Proxy @m) (Proxy @api) nt client) - :* hoistClientsMonad @m @mkApiRecord @apis @infos nt clients - -class DomainDrivenClientFields (mkApiRecord :: Type -> Type) (m :: Type -> Type) where - recordOfClientsFromFields - :: NP I (Clients (GenericRecordFields (mkApiRecord AsApi)) m) - -> mkApiRecord (AsClientT m) - recordOfClientsToFields - :: mkApiRecord (AsClientT m) - -> NP I (Clients (GenericRecordFields (mkApiRecord AsApi)) m) - -instance - ( GHC.Generic (mkApiRecord (AsClientT m)) - , GCode (mkApiRecord (AsClientT m)) - ~ '[Clients (GenericRecordFields (mkApiRecord AsApi)) m] - , GFrom (mkApiRecord (AsClientT m)) - , GTo (mkApiRecord (AsClientT m)) - ) - => DomainDrivenClientFields mkApiRecord m - where - recordOfClientsFromFields = gto . SOP . Z - recordOfClientsToFields x = case unSOP $ gfrom x of - Z servers -> servers - S y -> case y of {} - -instance - ( RunClient m - , DomainDrivenApiHasClients - m - mkApiRecord - (GenericRecordFields (mkApiRecord model event AsApi)) - (GenericRecordFieldInfos (mkApiRecord model event AsApi)) - , forall n. DomainDrivenClientFields (mkApiRecord model event) n - ) - => HasClient m (DomainDrivenApi mkApiRecord model event) - where - type - Client m (DomainDrivenApi mkApiRecord model event) = - mkApiRecord model event (AsClientT m) - clientWithRoute _ _ = - recordOfClientsFromFields - . ( clientsWithRoute @m @mkApiRecord - @(GenericRecordFields (mkApiRecord model event AsApi)) - @(GenericRecordFieldInfos (mkApiRecord model event AsApi)) - ) - hoistClientMonad _ _ nt = - recordOfClientsFromFields - . hoistClientsMonad @m @mkApiRecord - @(GenericRecordFields (mkApiRecord model event AsApi)) - @(GenericRecordFieldInfos (mkApiRecord model event AsApi)) - nt - . recordOfClientsToFields diff --git a/domaindriven/src/DomainDriven/Server/Helper/GenericRecord.hs b/domaindriven/src/DomainDriven/Server/Helper/GenericRecord.hs deleted file mode 100644 index f92ef6c..0000000 --- a/domaindriven/src/DomainDriven/Server/Helper/GenericRecord.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - -module DomainDriven.Server.Helper.GenericRecord where - -import Data.Kind -import GHC.TypeLits -import Generics.SOP.GGP -import Generics.SOP.Type.Metadata - -type family GenericRecordFields (record :: Type) :: [Type] where - GenericRecordFields record = GenericRecordFields' (GCode record) - -type family GenericRecordFields' (code :: [[Type]]) :: [Type] where - GenericRecordFields' '[fields] = fields - GenericRecordFields' t = TypeError ('ShowType t ':<>: 'Text " is not a record!") - -type family GenericRecordFieldInfos (record :: Type) :: [FieldInfo] where - GenericRecordFieldInfos record = GenericRecordFieldInfos' (GDatatypeInfoOf record) - -type family GenericRecordFieldInfos' (info :: DatatypeInfo) :: [FieldInfo] where - GenericRecordFieldInfos' ('ADT _ _ '[ 'Record _ infos] _) = infos - GenericRecordFieldInfos' t = TypeError ('ShowType t ':<>: 'Text " is not a record!") diff --git a/domaindriven/src/DomainDriven/Server/MapModel.hs b/domaindriven/src/DomainDriven/Server/MapModel.hs deleted file mode 100644 index c3d7595..0000000 --- a/domaindriven/src/DomainDriven/Server/MapModel.hs +++ /dev/null @@ -1,242 +0,0 @@ --- These instances can no doubt be simplified a little bit... -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE UndecidableInstances #-} - -module DomainDriven.Server.MapModel where - -import Control.Arrow -import Control.Monad -import Data.Kind -import DomainDriven.Server.DomainDrivenApi -import DomainDriven.Server.Server -import GHC.Generics qualified as GHC -import Generics.SOP.BasicFunctors -import Generics.SOP.GGP -import Generics.SOP.NP hiding (Projection) -import Generics.SOP.NS -import Servant hiding (inject) -import Prelude - -class MapModelAndEvent serverFrom serverTo where - type ModelFrom serverFrom :: Type - type ModelTo serverTo :: Type - type EventFrom serverFrom :: Type - type EventTo serverTo :: Type - mapModelAndEvent - :: (ModelTo serverTo -> ModelFrom serverFrom) - -> (EventFrom serverFrom -> EventTo serverTo) - -> serverFrom - -> serverTo - -class MapEvent serverFrom serverTo where - mapEvent - :: (EventFrom serverFrom -> EventTo serverTo) - -> serverFrom - -> serverTo - -instance - ( serverFrom ~ DomainDrivenServer mkServer modelTo eventFrom m - , MapModelAndEvent - (DomainDrivenServer mkServer modelTo eventFrom m) - (DomainDrivenServer mkServer modelTo eventTo m) - ) - => MapEvent - serverFrom - (DomainDrivenServer mkServer modelTo eventTo m) - where - mapEvent = mapModelAndEvent id - -class MapModel serverFrom serverTo where - mapModel - :: (ModelTo serverTo -> ModelFrom serverFrom) - -> serverFrom - -> serverTo - -instance - ( serverFrom ~ DomainDrivenServer mkServer modelFrom eventTo m - , MapModelAndEvent - (DomainDrivenServer mkServer modelFrom eventTo m) - (DomainDrivenServer mkServer modelTo eventTo m) - ) - => MapModel - serverFrom - (DomainDrivenServer mkServer modelTo eventTo m) - where - mapModel f = mapModelAndEvent f id - -instance - ( mkServerFrom ~ mkServerTo - , mFrom ~ mTo - , MapModelAndEvent' - modelFrom - modelTo - eventFrom - eventTo - (DomainDrivenServer mkServerTo modelFrom eventFrom mTo) - (DomainDrivenServer mkServerTo modelTo eventTo mTo) - ) - => MapModelAndEvent - (DomainDrivenServer mkServerFrom modelFrom eventFrom mFrom) - (DomainDrivenServer mkServerTo modelTo eventTo mTo) - where - type ModelFrom (DomainDrivenServer mkServerFrom modelFrom eventFrom mFrom) = modelFrom - type ModelTo (DomainDrivenServer mkServerTo modelTo eventTo mTo) = modelTo - type EventFrom (DomainDrivenServer mkServerFrom modelFrom eventFrom mFrom) = eventFrom - type EventTo (DomainDrivenServer mkServerTo modelTo eventTo mTo) = eventTo - mapModelAndEvent = mapModelAndEvent' - -class MapModelAndEvent' modelFrom modelTo eventFrom eventTo serverFrom serverTo where - mapModelAndEvent' - :: (modelTo -> modelFrom) - -> (eventFrom -> eventTo) - -> serverFrom - -> serverTo - -instance - {-# OVERLAPPABLE #-} - serverFrom ~ serverTo - => MapModelAndEvent' modelFrom modelTo eventFrom eventTo serverFrom serverTo - where - mapModelAndEvent' _ _ = id - -instance - ( modelFrom ~ modelFrom' - , eventFrom ~ eventFrom' - , modelTo ~ modelTo' - , eventTo ~ eventTo' - , aFrom ~ aTo - , mFrom ~ mTo - ) - => MapModelAndEvent' - modelFrom - modelTo - eventFrom - eventTo - (CbCmdServer modelFrom' eventFrom' mFrom aFrom) - (CbCmdServer modelTo' eventTo' mTo aTo) - where - mapModelAndEvent' proj inj (CbCmd server) = - CbCmd $ \transact -> - server - ( \action -> transact $ - \model -> ((. proj) *** map inj) <$> action (proj model) - ) - -instance - ( modelFrom ~ modelFrom' - , eventFrom ~ eventFrom' - , modelTo ~ modelTo' - , eventTo ~ eventTo' - , aFrom ~ aTo - , mFrom ~ mTo - , Functor mFrom - ) - => MapModelAndEvent' - modelFrom - modelTo - eventFrom - eventTo - (CmdServer modelFrom' eventFrom' mFrom aFrom) - (CmdServer modelTo' eventTo' mTo aTo) - where - mapModelAndEvent' proj inj (Cmd server) = - Cmd $ \model -> ((. proj) *** map inj) <$> server (proj model) - -instance - ( modelFrom ~ modelFrom' - , modelTo ~ modelTo' - , aFrom ~ aTo - , mFrom ~ mTo - ) - => MapModelAndEvent' - modelFrom - modelTo - eventFrom - eventTo - (QueryServer modelFrom' mFrom aFrom) - (QueryServer modelTo' mTo aTo) - where - mapModelAndEvent' proj _ (Query server) = Query $ server . proj - -instance - ( modelFrom ~ modelFrom' - , modelTo ~ modelTo' - , aFrom ~ aTo - , mFrom ~ mTo - ) - => MapModelAndEvent' - modelFrom - modelTo - eventFrom - eventTo - (CbQueryServer modelFrom' mFrom aFrom) - (CbQueryServer modelTo' mTo aTo) - where - mapModelAndEvent' proj _ (CbQuery server) = CbQuery $ \model -> server (proj <$> model) - -instance - (aFrom ~ aTo, MapModelAndEvent' modelFrom modelTo eventFrom eventTo serverFrom serverTo) - => MapModelAndEvent' - modelFrom - modelTo - eventFrom - eventTo - (aFrom -> serverFrom) - (aTo -> serverTo) - where - mapModelAndEvent' proj inj server a = mapModelAndEvent' proj inj (server a) - -instance - ( MapModelAndEvent' modelFrom modelTo eventFrom eventTo serverFrom1 serverTo1 - , MapModelAndEvent' modelFrom modelTo eventFrom eventTo serverFrom2 serverTo2 - ) - => MapModelAndEvent' - modelFrom - modelTo - eventFrom - eventTo - (serverFrom1 :<|> serverFrom2) - (serverTo1 :<|> serverTo2) - where - mapModelAndEvent' proj inj (server :<|> server2) = - mapModelAndEvent' proj inj server :<|> mapModelAndEvent' proj inj server2 - -instance - ( MapModelAndEvent' modelFrom modelTo eventFrom eventTo t u - , MapModelAndEvent' modelFrom modelTo eventFrom eventTo (NP I ts) (NP I us) - ) - => MapModelAndEvent' modelFrom modelTo eventFrom eventTo (NP I (t ': ts)) (NP I (u ': us)) - where - mapModelAndEvent' proj inj (I t :* ts) = - I (mapModelAndEvent' proj inj t) :* mapModelAndEvent' proj inj ts - -instance - MapModelAndEvent' modelFrom modelTo eventFrom eventTo (NP I fields) (NP I fields') - => MapModelAndEvent' modelFrom modelTo eventFrom eventTo (SOP I '[fields]) (SOP I '[fields']) - where - mapModelAndEvent' proj inj (SOP x) = case x of - Z fields -> SOP (Z $ mapModelAndEvent' proj inj fields) - S xs -> case xs of {} - -instance - ( GHC.Generic (DomainDrivenServer mkServer modelFrom eventFrom m) - , GHC.Generic (DomainDrivenServer mkServer modelTo eventTo m) - , GFrom (DomainDrivenServer mkServer modelFrom eventFrom m) - , GTo (DomainDrivenServer mkServer modelTo eventTo m) - , MapModelAndEvent' - modelFrom - modelTo - eventFrom - eventTo - (SOP I (GCode (DomainDrivenServer mkServer modelFrom eventFrom m))) - (SOP I (GCode (DomainDrivenServer mkServer modelTo eventTo m))) - ) - => MapModelAndEvent' - modelFrom - modelTo - eventFrom - eventTo - (DomainDrivenServer mkServer modelFrom eventFrom m) - (DomainDrivenServer mkServer modelTo eventTo m) - where - mapModelAndEvent' proj inj = gto . mapModelAndEvent' proj inj . gfrom diff --git a/domaindriven/src/DomainDriven/Server/Server.hs b/domaindriven/src/DomainDriven/Server/Server.hs deleted file mode 100644 index 3fea7d9..0000000 --- a/domaindriven/src/DomainDriven/Server/Server.hs +++ /dev/null @@ -1,301 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} --- needed for context entry. todo: non-type-driven context lookup! -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module DomainDriven.Server.Server where - -import Control.Monad -import Control.Monad.Catch qualified -import Control.Monad.Except -import Data.Kind -import DomainDriven.Persistance.Class -import DomainDriven.Server.Api -import GHC.Stack -import GHC.TypeLits -import Servant hiding (inject) -import Servant.Auth.Server -import Servant.Server.Internal.Delayed -import UnliftIO hiding (Handler) -import Prelude - -data CmdServer (model :: Type) (event :: Type) m a where - Cmd :: HasCallStack => (model -> m (model -> a, [event])) -> CmdServer model event m a - -data QueryServer (model :: Type) m a where - Query :: HasCallStack => (model -> m a) -> QueryServer model m a - -data CbQueryServer (model :: Type) m a where - CbQuery :: ((forall n. (HasCallStack, MonadIO n) => n model) -> m a) -> CbQueryServer model m a - -data CbCmdServer (model :: Type) (event :: Type) m a where - CbCmd :: ((forall n b. (HasCallStack, MonadUnliftIO n) => - RunCmd model event n b) -> m a) -> CbCmdServer model event m a - - -instance MonadError ServerError m => ThrowAll (CmdServer model event m a) where - throwAll = Cmd . throwAll - -instance MonadError ServerError m => ThrowAll (CbCmdServer model event m a) where - throwAll err = CbCmd $ \_ -> throwAll err - -instance MonadError ServerError m => ThrowAll (QueryServer model m a) where - throwAll = Query . throwAll - -instance MonadError ServerError m => ThrowAll (CbQueryServer model m a) where - throwAll err = CbQuery $ \_ -> throwAll err - - -data CmdServerI (index :: Type) (model :: Type) (event :: Type) m a - = CmdI index (model -> m (model -> a, [event])) - -data QueryServerI (index :: Type) (model :: Type) m a - = QueryI index (model -> m a) - -data CbQueryServerI (index :: Type) (model :: Type) m a - = CbQueryI index ((forall n. MonadIO n => n model) -> m a) - -data CbCmdServerI (index :: Type) (model :: Type) (event :: Type) m a - = CbCmdI - index - ( ( forall n b - . (HasCallStack, MonadUnliftIO n) - => RunCmd model event n b - ) - -> m a - ) - -instance MonadError ServerError m => ThrowAll (CmdServerI model index event m a) where - throwAll = CmdI undefined . throwAll - -instance MonadError ServerError m => ThrowAll (CbCmdServerI model index event m a) where - throwAll err = CbCmdI undefined $ \_ -> throwAll err - -instance MonadError ServerError m => ThrowAll (QueryServerI model index m a) where - throwAll = QueryI undefined . throwAll - -instance MonadError ServerError m => ThrowAll (CbQueryServerI model index m a) where - throwAll err = CbQueryI undefined $ \_ -> throwAll err - -type family CanMutate (method :: StdMethod) :: Bool where - CanMutate 'GET = 'False - CanMutate 'POST = 'True - CanMutate 'PUT = 'True - CanMutate 'PATCH = 'True - CanMutate 'DELETE = 'True - CanMutate method = - TypeError - ( 'Text "CanMutate is not defined for " - ':<>: 'ShowType method - ) - -mapServer :: (a -> b) -> Delayed env a -> Delayed env b -mapServer f Delayed{..} = - Delayed - { serverD = \c p h a b req -> fmap f (serverD c p h a b req) - , .. - } - -data WritePersistence model index event - = forall p. - ( Model p ~ model - , Event p ~ event - , Index p ~ index - , WriteModel p - ) => - WritePersistence p -data ReadPersistence model index - = forall p. - ( Model p ~ model - , ReadModel p - , Index p ~ index - ) => - ReadPersistence p - -instance - ( HasServer (Verb method status ctypes a) context - , CanMutate method ~ 'True - , HasContextEntry context (WritePersistence model NoIndex event) - ) - => HasServer (Cmd' model event (Verb method status ctypes a)) context - where - type - ServerT (Cmd' model event (Verb method status ctypes a)) m = - CmdServer model event m a - hoistServerWithContext _ _ f (Cmd action) = Cmd $ \model -> f (action model) - - route _ context delayedServer = - case getContextEntry context :: WritePersistence model NoIndex event of - WritePersistence p -> - route (Proxy @(Verb method status ctypes a)) context $ - mapServer - ( \(Cmd server) -> do - handlerRes <- - liftIO . Control.Monad.Catch.try . runCmd p NoIndex $ - either throwIO pure <=< runHandler . server - either throwError pure handlerRes - ) - delayedServer -instance - ( HasServer (Verb method status ctypes a) context - , CanMutate method ~ 'True - , HasContextEntry context (WritePersistence model index event) - ) - => HasServer (CmdI' index model event (Verb method status ctypes a)) context - where - type - ServerT (CmdI' index model event (Verb method status ctypes a)) m = - CmdServerI index model event m a - hoistServerWithContext _ _ f (CmdI index action) = - CmdI index $ \model -> f (action model) - - route _ context delayedServer = - case getContextEntry context :: WritePersistence model index event of - WritePersistence p -> - route (Proxy @(Verb method status ctypes a)) context $ - mapServer - ( \(CmdI index server) -> do - handlerRes <- - liftIO . Control.Monad.Catch.try . runCmd p index $ - either throwIO pure <=< runHandler . server - either throwError pure handlerRes - ) - delayedServer - -instance - ( HasServer (Verb method status ctypes a) context - , HasContextEntry context (ReadPersistence model NoIndex) - ) - => HasServer (Query' model (Verb method status ctypes a)) context - where - type ServerT (Query' model (Verb method status ctypes a)) m = QueryServer model m a - - hoistServerWithContext _ _ f (Query action) = Query $ \model -> f (action model) - - route _ context delayedServer = - case getContextEntry context :: ReadPersistence model NoIndex of - ReadPersistence p -> - route (Proxy @(Verb method status ctypes a)) context $ - mapServer - ( \(Query server) -> server =<< liftIO (getModel p NoIndex) - ) - delayedServer -instance - ( HasServer (Verb method status ctypes a) context - , HasContextEntry context (ReadPersistence model index) - ) - => HasServer (QueryI' index model (Verb method status ctypes a)) context - where - type ServerT (QueryI' index model (Verb method status ctypes a)) m = - QueryServerI index model m a - - hoistServerWithContext _ _ f (QueryI index action) = - QueryI index $ \model -> f (action model) - - route _ context delayedServer = - case getContextEntry context :: ReadPersistence model index of - ReadPersistence p -> - route (Proxy @(Verb method status ctypes a)) context $ - mapServer - ( \(QueryI index server) -> server =<< liftIO (getModel p index) - ) - delayedServer - -instance - ( HasServer (Verb method status ctypes a) context - , HasContextEntry context (ReadPersistence model NoIndex) - ) - => HasServer (CbQuery' model (Verb method status ctypes a)) context - where - type - ServerT (CbQuery' model (Verb method status ctypes a)) m = - CbQueryServer model m a - - hoistServerWithContext _ _ f (CbQuery action) = CbQuery $ \model -> f (action model) - - route _ context delayedServer = - case getContextEntry context :: ReadPersistence model NoIndex of - ReadPersistence p -> - route (Proxy @(Verb method status ctypes a)) context $ - mapServer - ( \(CbQuery server) -> server (liftIO $ getModel p NoIndex) - ) - delayedServer - -instance - ( HasServer (Verb method status ctypes a) context - , HasContextEntry context (ReadPersistence model index) - ) - => HasServer (CbQueryI' index model (Verb method status ctypes a)) context - where - type - ServerT (CbQueryI' index model (Verb method status ctypes a)) m = - CbQueryServerI index model m a - - hoistServerWithContext _ _ f (CbQueryI index action) = - CbQueryI index $ \model -> f (action model) - - route _ context delayedServer = - case getContextEntry context :: ReadPersistence model index of - ReadPersistence p -> - route (Proxy @(Verb method status ctypes a)) context $ - mapServer - ( \(CbQueryI index server) -> server (liftIO $ getModel p index) - ) - delayedServer - -instance - ( HasServer (Verb method status ctypes a) context - , CanMutate method ~ 'True - , HasContextEntry context (WritePersistence model NoIndex event) - ) - => HasServer (CbCmd' model event (Verb method status ctypes a)) context - where - type - ServerT (CbCmd' model event (Verb method status ctypes a)) m = - CbCmdServer - model - event - m - a - - hoistServerWithContext _ _ f (CbCmd action) = - CbCmd $ \transact -> f (action transact) - - route _ context delayedServer = - case getContextEntry context :: WritePersistence model NoIndex event of - WritePersistence p -> - route (Proxy @(Verb method status ctypes a)) context $ - mapServer - ( \(CbCmd server) -> server $ runCmd p NoIndex - ) - delayedServer - -instance - ( HasServer (Verb method status ctypes a) context - , CanMutate method ~ 'True - , HasContextEntry context (WritePersistence model index event) - ) - => HasServer (CbCmdI' index model event (Verb method status ctypes a)) context - where - type - ServerT (CbCmdI' index model event (Verb method status ctypes a)) m = - CbCmdServerI - index - model - event - m - a - - hoistServerWithContext _ _ f (CbCmdI index action) = - CbCmdI index $ \transact -> f (action transact) - - route _ context delayedServer = - case getContextEntry context :: WritePersistence model index event of - WritePersistence p -> - route (Proxy @(Verb method status ctypes a)) context $ - mapServer - ( \(CbCmdI index server) -> server $ runCmd p index - ) - delayedServer diff --git a/domaindriven/src/Servant/Auth/Internal/ThrowAll/SOP.hs b/domaindriven/src/Servant/Auth/Internal/ThrowAll/SOP.hs deleted file mode 100644 index 09a7d0c..0000000 --- a/domaindriven/src/Servant/Auth/Internal/ThrowAll/SOP.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - -module Servant.Auth.Internal.ThrowAll.SOP where - -import Generics.SOP (I (..), NP (Nil, (:*)), NS (..), SOP (..)) -import Servant.Auth.Server.Internal.ThrowAll -import Prelude - -instance ThrowAll (NP I '[]) where - throwAll _ = Nil - -instance (ThrowAll (NP I cs), ThrowAll c) => ThrowAll (NP I (c ': cs)) where - throwAll err = I (throwAll err) :* throwAll err - -instance ThrowAll (NP I servers) => ThrowAll (SOP I '[servers]) where - throwAll = SOP . Z . throwAll diff --git a/domaindriven/test/Spec.hs b/domaindriven/test/Spec.hs deleted file mode 100644 index a824f8c..0000000 --- a/domaindriven/test/Spec.hs +++ /dev/null @@ -1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/stack.yaml b/stack.yaml index 06023c5..8e13fb6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,8 +3,6 @@ packages: - domaindriven-core - domaindriven-effectful - domaindriven-effectful-examples -- domaindriven -- domaindriven-examples extra-deps: - openapi3-3.2.4 From 293a0ac344bf5877b41da9fc071b022a466f7011 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Sat, 13 Sep 2025 14:38:00 +0200 Subject: [PATCH 24/50] tmp --- .../src/DomainDriven/Persistance/Postgres.hs | 1 + .../domaindriven-effectful-examples.cabal | 56 +++++++++++- domaindriven-effectful-examples/package.yaml | 18 +++- .../{simple-named => postgres}/Main.hs | 86 ++++++++----------- .../simple/Main.hs | 46 ++++------ .../src/DomainDriven/Effectful.hs | 1 + .../Effectful/Interpreter/InMemory.hs | 4 +- .../Effectful/Interpreter/Postgres.hs | 12 +-- 8 files changed, 138 insertions(+), 86 deletions(-) rename domaindriven-effectful-examples/{simple-named => postgres}/Main.hs (60%) diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres.hs index d952e83..4c823c4 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres.hs @@ -13,6 +13,7 @@ import DomainDriven.Persistance.Postgres.Internal as X import DomainDriven.Persistance.Postgres.Types as X ( ChunkSize , EventMigration + , IsPgIndex (..) , EventTable (..) , EventTableBaseName , EventTableName diff --git a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal index 48b02f0..429bd96 100644 --- a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal +++ b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal @@ -23,7 +23,61 @@ source-repository head type: git location: https://github.com/tommyengstrom/domaindriven -executable effectful-example +executable postgres-example + main-is: Main.hs + other-modules: + Paths_domaindriven_effectful_examples + hs-source-dirs: + simple + default-extensions: + BlockArguments + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedLabels + OverloadedStrings + PolyKinds + RankNTypes + ScopedTypeVariables + StandaloneDeriving + StrictData + TupleSections + TypeApplications + TypeFamilyDependencies + TypeOperators + TypeSynonymInstances + ViewPatterns + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wno-unused-packages -fplugin=Effectful.Plugin -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base + , domaindriven-core + , domaindriven-effectful + , effectful + , effectful-core + , effectful-plugin + , servant + , servant-server + , warp + default-language: Haskell2010 + +executable simple-example main-is: Main.hs other-modules: Paths_domaindriven_effectful_examples diff --git a/domaindriven-effectful-examples/package.yaml b/domaindriven-effectful-examples/package.yaml index ce65054..ab040fc 100644 --- a/domaindriven-effectful-examples/package.yaml +++ b/domaindriven-effectful-examples/package.yaml @@ -69,7 +69,23 @@ ghc-options: - -fplugin=Effectful.Plugin executables: - effectful-example: + simple-example: + main: Main.hs + source-dirs: simple + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - aeson + - domaindriven-core + - domaindriven-effectful + - effectful + - servant + - servant-server + - warp + + postgres-example: main: Main.hs source-dirs: simple ghc-options: diff --git a/domaindriven-effectful-examples/simple-named/Main.hs b/domaindriven-effectful-examples/postgres/Main.hs similarity index 60% rename from domaindriven-effectful-examples/simple-named/Main.hs rename to domaindriven-effectful-examples/postgres/Main.hs index 851cef0..96d4fe0 100644 --- a/domaindriven-effectful-examples/simple-named/Main.hs +++ b/domaindriven-effectful-examples/postgres/Main.hs @@ -1,17 +1,9 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - module Main where import Control.Monad (when) -import Data.Aeson import DomainDriven.Effectful -import DomainDriven.Effectful.Interpreter.InMemory -import DomainDriven.FieldNameAsPath -import DomainDriven.Persistance.Class (NoIndex (..), Stored (..)) -import DomainDriven.Persistance.ForgetfulInMemory (ForgetfulInMemory, createForgetful) +import DomainDriven.Persistance.Class (WriteModel) +import DomainDriven.Effectful.Interpreter.Postgres import Effectful hiding ((:>)) import Effectful qualified import Effectful.Error.Static @@ -19,41 +11,45 @@ import Network.Wai.Handler.Warp (run) import Servant hiding (throwError) import Servant qualified import Servant.API.Generic -import Servant.Server.Generic (AsServerT) +import Servant.Server.Generic (AsServerT, genericServeT) import Prelude -------------------------------------------------------------------------------- --- 1. Define the model +-- Define the model -------------------------------------------------------------------------------- type CounterModel = Int -------------------------------------------------------------------------------- --- 2. Define events and how to apply them +-- Define events -------------------------------------------------------------------------------- data CounterEvent = Increase | Decrease - deriving (Show, Eq, Generic, ToJSON, FromJSON) + deriving (Show) +-------------------------------------------------------------------------------- +-- Define event handler +-------------------------------------------------------------------------------- applyEvent :: CounterModel -> Stored CounterEvent -> CounterModel -applyEvent i (Stored ev _ _) = case ev of +applyEvent i (Stored ev _timestamp _uuid) = case ev of Increase -> i + 1 Decrease -> i - 1 +-- Define the domain, used to cary the type constraints type CounterDomain = Domain CounterModel CounterEvent NoIndex -------------------------------------------------------------------------------- --- 3. Define the Servant API +-- Use Servant to define the Commands -------------------------------------------------------------------------------- data CounterAPI mode = CounterAPI { get :: mode :- Get '[JSON] Int , increase :: mode :- "increase" :> Post '[JSON] Int , decrease :: mode :- "decrease" :> Post '[JSON] Int } - deriving (Generic, ApiTagFromLabel) + deriving (Generic) -------------------------------------------------------------------------------- --- 4. Implement the server handlers using Effectful effects +-- Implement the server handlers using Effectful effects -------------------------------------------------------------------------------- -- | Counter handlers using Effectful effects @@ -63,7 +59,6 @@ counterServer , Error ServerError Effectful.:> es ) => CounterAPI (AsServerT (Eff es)) - counterServer = CounterAPI { get = getModel @@ -71,33 +66,21 @@ counterServer = pure (id, [Increase]) , decrease = runTransaction do m <- getModel - when (id m <= 0) - . throwError - $ err422{errBody = "Counter cannot go below zero"} + when + (m <= 0) + (throwError err422{errBody = "Counter cannot go below zero"}) pure (id, [Decrease]) } -counterServer' - :: ( Projection CounterDomain Effectful.:> es - , Aggregate CounterDomain Effectful.:> es - , Error ServerError Effectful.:> es - ) - => ServerT (FieldNameAsPathApi CounterAPI) (Eff es) -counterServer' = FieldNameAsPathServer counterServer - -------------------------------------------------------------------------------- --- 5. Wire up the server with effect interpreters +-- Create the servant application. +-- Here we have to run all the effects and transform it to Servant's Handler monad. -------------------------------------------------------------------------------- - -mkCounterServer' :: ForgetfulInMemory CounterModel NoIndex CounterEvent -> Application -mkCounterServer' backend = - serveWithContextT - (Proxy @(FieldNameAsPathApi CounterAPI)) - EmptyContext - runEffects - counterServer' +mkCounterServer :: PostgresEvent NoIndex CounterModel CounterEvent + -> Application +mkCounterServer backend = + genericServeT runEffects counterServer where - -- Helper to run effects and convert to Handler runEffects :: Eff '[ Projection CounterDomain @@ -112,21 +95,26 @@ mkCounterServer' backend = liftIO . runEff . runErrorNoCallStack @ServerError - . runAggregateInMemory backend - $ runProjectionInMemory backend m + . runAggregatePostgres backend + $ runProjectionPostgres backend m either Servant.throwError pure a - +eventTable :: EventTable +eventTable = InitialVersion "counter_events" +-------------------------------------------------------------------------------- +-- Run the server +-------------------------------------------------------------------------------- main :: IO () main = do let port = 7878 putStrLn $ "Running Effectful counter on port " <> show port -- Initialize the in-memory backend - backend <- createForgetful @NoIndex applyEvent 0 - + connectionPool <- simplePool undefined + backend <- postgresWriteModel + simplePool + eventTable + applyEvent + (0 :: CounterModel) -- Create and run the application - let app = mkCounterServer' backend - - run port app - + run port $ mkCounterServer backend diff --git a/domaindriven-effectful-examples/simple/Main.hs b/domaindriven-effectful-examples/simple/Main.hs index eaad4fe..da57b4f 100644 --- a/domaindriven-effectful-examples/simple/Main.hs +++ b/domaindriven-effectful-examples/simple/Main.hs @@ -1,16 +1,8 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - module Main where import Control.Monad (when) -import Data.Aeson import DomainDriven.Effectful import DomainDriven.Effectful.Interpreter.InMemory -import DomainDriven.Persistance.Class (NoIndex (..), Stored (..)) -import DomainDriven.Persistance.ForgetfulInMemory (ForgetfulInMemory, createForgetful) import Effectful hiding ((:>)) import Effectful qualified import Effectful.Error.Static @@ -22,24 +14,23 @@ import Servant.Server.Generic (AsServerT, genericServeT) import Prelude -------------------------------------------------------------------------------- --- 1. Define the model +-- Define the model -------------------------------------------------------------------------------- type CounterModel = Int -------------------------------------------------------------------------------- --- 2. Define events +-- Define events -------------------------------------------------------------------------------- data CounterEvent = Increase | Decrease - deriving (Show, Eq, Generic, ToJSON, FromJSON) - + deriving (Show) -------------------------------------------------------------------------------- --- 2. Define event handler +-- Define event handler -------------------------------------------------------------------------------- applyEvent :: CounterModel -> Stored CounterEvent -> CounterModel -applyEvent i (Stored ev _ _) = case ev of +applyEvent i (Stored ev _timestamp _uuid) = case ev of Increase -> i + 1 Decrease -> i - 1 @@ -47,7 +38,7 @@ applyEvent i (Stored ev _ _) = case ev of type CounterDomain = Domain CounterModel CounterEvent NoIndex -------------------------------------------------------------------------------- --- 3. Define the Servant API +-- Use Servant to define the Commands -------------------------------------------------------------------------------- data CounterAPI mode = CounterAPI { get :: mode :- Get '[JSON] Int @@ -57,7 +48,7 @@ data CounterAPI mode = CounterAPI deriving (Generic) -------------------------------------------------------------------------------- --- 4. Implement the server handlers using Effectful effects +-- Implement the server handlers using Effectful effects -------------------------------------------------------------------------------- -- | Counter handlers using Effectful effects @@ -67,7 +58,6 @@ counterServer , Error ServerError Effectful.:> es ) => CounterAPI (AsServerT (Eff es)) - counterServer = CounterAPI { get = getModel @@ -75,25 +65,20 @@ counterServer = pure (id, [Increase]) , decrease = runTransaction do m <- getModel - when (id m <= 0) - . throwError - $ err422{errBody = "Counter cannot go below zero"} + when + (m <= 0) + (throwError err422{errBody = "Counter cannot go below zero"}) pure (id, [Decrease]) } - --- | Create the counter server with effect interpreters - -------------------------------------------------------------------------------- --- 5. Wire up the server with effect interpreters +-- Create the servant application. +-- Here we have to run all the effects and transform it to Servant's Handler monad. -------------------------------------------------------------------------------- - --- | Create the counter server with effect interpreters mkCounterServer :: ForgetfulInMemory CounterModel NoIndex CounterEvent -> Application mkCounterServer backend = genericServeT runEffects counterServer where - -- Helper to run effects and convert to Handler runEffects :: Eff '[ Projection CounterDomain @@ -109,16 +94,19 @@ mkCounterServer backend = . runEff . runErrorNoCallStack @ServerError . runAggregateInMemory backend - $ runProjectionInMemory backend m + $ runProjectionInMemory backend m either Servant.throwError pure a +-------------------------------------------------------------------------------- +-- Run the server +-------------------------------------------------------------------------------- main :: IO () main = do let port = 7878 putStrLn $ "Running Effectful counter on port " <> show port -- Initialize the in-memory backend - backend <- createForgetful @NoIndex applyEvent 0 + backend <- createForgetful applyEvent 0 -- Create and run the application run port $ mkCounterServer backend diff --git a/domaindriven-effectful/src/DomainDriven/Effectful.hs b/domaindriven-effectful/src/DomainDriven/Effectful.hs index 6241335..9900470 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful.hs @@ -6,6 +6,7 @@ module DomainDriven.Effectful ) where +import DomainDriven.Persistance.Class as X (Indexed(..),NoIndex (..), Stored (..)) import DomainDriven.Effectful.Domain import DomainDriven.Effectful.Aggregate as X import DomainDriven.Effectful.Projection as X diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs index 908a8a5..73c0393 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs @@ -6,7 +6,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} -module DomainDriven.Effectful.Interpreter.InMemory where +module DomainDriven.Effectful.Interpreter.InMemory + ( module DomainDriven.Effectful.Interpreter.InMemory + ) where import DomainDriven.Effectful.Aggregate import DomainDriven.Effectful.Projection diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs index 907e2f0..9988330 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs @@ -6,7 +6,10 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -module DomainDriven.Effectful.Interpreter.Postgres where +module DomainDriven.Effectful.Interpreter.Postgres + ( module DomainDriven.Effectful.Interpreter.Postgres + , module DomainDriven.Persistance.Postgres + ) where import Data.Aeson import DomainDriven.Effectful.Aggregate @@ -14,8 +17,7 @@ import DomainDriven.Effectful.Domain import DomainDriven.Effectful.Projection import DomainDriven.Persistance.Class (WriteModel) import DomainDriven.Persistance.Class qualified as P -import DomainDriven.Persistance.Postgres.Internal -import DomainDriven.Persistance.Postgres.Types +import DomainDriven.Persistance.Postgres import Effectful import Effectful.Dispatch.Dynamic import Prelude @@ -38,7 +40,7 @@ runProjectionPostgres backend = interpret $ \_ -> \case GetEventListI idx -> liftIO $ P.getEventList backend idx -- | Run the Aggregate effect using an in-memory backend (new domain API) -runAggregateInMemory +runAggregatePostgres :: forall domain es a index . ( IOE :> es , index ~ (DomainIndex domain) @@ -49,7 +51,7 @@ runAggregateInMemory => PostgresEvent (DomainModel domain) (DomainIndex domain) (DomainEvent domain) -> Eff (Aggregate domain : es) a -> Eff es a -runAggregateInMemory backend = interpret $ \env -> \case +runAggregatePostgres backend = interpret $ \env -> \case RunTransactionI idx cmd -> do localSeqUnlift env $ \unlift -> P.runCmd backend idx $ unlift cmd From 7b331abd3aa8252a0172eae0e9949a0d50234820 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Sat, 13 Sep 2025 14:53:30 +0200 Subject: [PATCH 25/50] it compiles --- .../domaindriven-effectful-examples.cabal | 2 +- domaindriven-effectful-examples/package.yaml | 2 +- domaindriven-effectful-examples/postgres/Main.hs | 6 +++--- .../src/DomainDriven/Effectful/Aggregate.hs | 14 -------------- .../DomainDriven/Effectful/Interpreter/InMemory.hs | 1 + .../DomainDriven/Effectful/Interpreter/Postgres.hs | 10 +++++----- 6 files changed, 11 insertions(+), 24 deletions(-) diff --git a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal index 429bd96..4945f29 100644 --- a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal +++ b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal @@ -28,7 +28,7 @@ executable postgres-example other-modules: Paths_domaindriven_effectful_examples hs-source-dirs: - simple + postgres default-extensions: BlockArguments ConstraintKinds diff --git a/domaindriven-effectful-examples/package.yaml b/domaindriven-effectful-examples/package.yaml index ab040fc..7f8896b 100644 --- a/domaindriven-effectful-examples/package.yaml +++ b/domaindriven-effectful-examples/package.yaml @@ -87,7 +87,7 @@ executables: postgres-example: main: Main.hs - source-dirs: simple + source-dirs: postgres ghc-options: - -threaded - -rtsopts diff --git a/domaindriven-effectful-examples/postgres/Main.hs b/domaindriven-effectful-examples/postgres/Main.hs index 96d4fe0..69d20cd 100644 --- a/domaindriven-effectful-examples/postgres/Main.hs +++ b/domaindriven-effectful-examples/postgres/Main.hs @@ -1,8 +1,8 @@ module Main where import Control.Monad (when) +import Data.Aeson import DomainDriven.Effectful -import DomainDriven.Persistance.Class (WriteModel) import DomainDriven.Effectful.Interpreter.Postgres import Effectful hiding ((:>)) import Effectful qualified @@ -25,7 +25,7 @@ type CounterModel = Int data CounterEvent = Increase | Decrease - deriving (Show) + deriving (Show, Generic, ToJSON, FromJSON) -------------------------------------------------------------------------------- -- Define event handler @@ -112,7 +112,7 @@ main = do -- Initialize the in-memory backend connectionPool <- simplePool undefined backend <- postgresWriteModel - simplePool + connectionPool eventTable applyEvent (0 :: CounterModel) diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs index 3c5e718..8827c68 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs @@ -38,17 +38,3 @@ runTransaction ) -> Eff es a runTransaction = runTransactionI NoIndex --- | Run a synchronous transaction while holding a lock on the aggregate --- The returnd value is a projection of the model after the events have been applied. --- runTransactionI --- :: forall domain es a --- . Aggregate domain :> es --- => DomainIndex domain --- -> ( Eff --- es --- ( DomainModel domain -> a --- , [DomainEvent domain] --- ) --- ) --- -> Eff es a --- runTransactionI idx cmd = send (RunTransactionI @domain idx cmd) diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs index 73c0393..332389b 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs @@ -8,6 +8,7 @@ module DomainDriven.Effectful.Interpreter.InMemory ( module DomainDriven.Effectful.Interpreter.InMemory + , createForgetful, ForgetfulInMemory ) where import DomainDriven.Effectful.Aggregate diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs index 9988330..6d02864 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs @@ -29,10 +29,10 @@ runProjectionPostgres , FromJSON (DomainEvent domain) , IsPgIndex index , index ~ (DomainIndex domain) - , P.Index (PostgresEvent (DomainModel domain) (DomainIndex domain) (DomainEvent domain)) + , P.Index (PostgresEvent (DomainIndex domain) (DomainModel domain) (DomainEvent domain)) ~ index ) - => PostgresEvent (DomainModel domain) (DomainIndex domain) (DomainEvent domain) + => PostgresEvent (DomainIndex domain) (DomainModel domain) (DomainEvent domain) -> Eff (Projection domain : es) a -> Eff es a runProjectionPostgres backend = interpret $ \_ -> \case @@ -44,11 +44,11 @@ runAggregatePostgres :: forall domain es a index . ( IOE :> es , index ~ (DomainIndex domain) - , P.Index (PostgresEvent (DomainModel domain) (DomainIndex domain) (DomainEvent domain)) + , P.Index (PostgresEvent (DomainIndex domain) (DomainModel domain) (DomainEvent domain)) ~ index - , WriteModel (PostgresEvent (DomainModel domain) (DomainIndex domain) (DomainEvent domain)) + , WriteModel (PostgresEvent (DomainIndex domain) (DomainModel domain) (DomainEvent domain)) ) - => PostgresEvent (DomainModel domain) (DomainIndex domain) (DomainEvent domain) + => PostgresEvent (DomainIndex domain) (DomainModel domain) (DomainEvent domain) -> Eff (Aggregate domain : es) a -> Eff es a runAggregatePostgres backend = interpret $ \env -> \case From aff4e8667f65daa22fc81a1847d730263e00c70c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Sat, 13 Sep 2025 14:59:25 +0200 Subject: [PATCH 26/50] postgresql example --- .../domaindriven-effectful-examples.cabal | 1 + domaindriven-effectful-examples/package.yaml | 1 + domaindriven-effectful-examples/postgres/Main.hs | 4 +++- .../src/DomainDriven/Effectful/Interpreter/Postgres.hs | 4 ---- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal index 4945f29..7b5b628 100644 --- a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal +++ b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal @@ -72,6 +72,7 @@ executable postgres-example , effectful , effectful-core , effectful-plugin + , postgresql-simple , servant , servant-server , warp diff --git a/domaindriven-effectful-examples/package.yaml b/domaindriven-effectful-examples/package.yaml index 7f8896b..e398720 100644 --- a/domaindriven-effectful-examples/package.yaml +++ b/domaindriven-effectful-examples/package.yaml @@ -100,4 +100,5 @@ executables: - servant - servant-server - warp + - postgresql-simple diff --git a/domaindriven-effectful-examples/postgres/Main.hs b/domaindriven-effectful-examples/postgres/Main.hs index 69d20cd..2717d6e 100644 --- a/domaindriven-effectful-examples/postgres/Main.hs +++ b/domaindriven-effectful-examples/postgres/Main.hs @@ -5,6 +5,7 @@ import Data.Aeson import DomainDriven.Effectful import DomainDriven.Effectful.Interpreter.Postgres import Effectful hiding ((:>)) +import Database.PostgreSQL.Simple (connectPostgreSQL) import Effectful qualified import Effectful.Error.Static import Network.Wai.Handler.Warp (run) @@ -110,7 +111,8 @@ main = do putStrLn $ "Running Effectful counter on port " <> show port -- Initialize the in-memory backend - connectionPool <- simplePool undefined + connectionPool <- simplePool + $ connectPostgreSQL "host=localhost port=5432 user=postgres dbname=domaindriven password=postgres" backend <- postgresWriteModel connectionPool eventTable diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs index 6d02864..9a01e13 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs @@ -29,8 +29,6 @@ runProjectionPostgres , FromJSON (DomainEvent domain) , IsPgIndex index , index ~ (DomainIndex domain) - , P.Index (PostgresEvent (DomainIndex domain) (DomainModel domain) (DomainEvent domain)) - ~ index ) => PostgresEvent (DomainIndex domain) (DomainModel domain) (DomainEvent domain) -> Eff (Projection domain : es) a @@ -44,8 +42,6 @@ runAggregatePostgres :: forall domain es a index . ( IOE :> es , index ~ (DomainIndex domain) - , P.Index (PostgresEvent (DomainIndex domain) (DomainModel domain) (DomainEvent domain)) - ~ index , WriteModel (PostgresEvent (DomainIndex domain) (DomainModel domain) (DomainEvent domain)) ) => PostgresEvent (DomainIndex domain) (DomainModel domain) (DomainEvent domain) From d1ba23731e9aea9874035fb97c928035764369df Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Sat, 13 Sep 2025 15:42:09 +0200 Subject: [PATCH 27/50] migration example --- domaindriven-core/src/Data/ShapeCoerce.hs | 357 ++++++++++-------- .../src/DomainDriven/Persistance/Class.hs | 5 +- .../Persistance/ForgetfulInMemory.hs | 25 +- .../src/DomainDriven/Persistance/Postgres.hs | 2 +- .../Persistance/Postgres/Internal.hs | 3 +- .../Persistance/Postgres/Migration.hs | 7 +- .../Persistance/Postgres/Types.hs | 8 +- .../DomainDriven/Persistance/PostgresSpec.hs | 54 ++- .../domaindriven-effectful-examples.cabal | 7 +- domaindriven-effectful-examples/package.yaml | 1 + .../postgres/Event/V1.hs | 28 ++ .../postgres/Event/V2.hs | 30 ++ .../postgres/EventMigration.hs | 58 +++ .../postgres/Main.hs | 23 +- .../simple/Main.hs | 4 +- .../src/DomainDriven/Effectful.hs | 8 +- .../src/DomainDriven/Effectful/Aggregate.hs | 30 +- .../Effectful/Interpreter/InMemory.hs | 23 +- .../Effectful/Interpreter/Postgres.hs | 6 +- .../src/DomainDriven/Effectful/Projection.hs | 28 +- .../src/DomainDriven/FieldNameAsPath.hs | 80 ++-- 21 files changed, 486 insertions(+), 301 deletions(-) create mode 100644 domaindriven-effectful-examples/postgres/Event/V1.hs create mode 100644 domaindriven-effectful-examples/postgres/Event/V2.hs create mode 100644 domaindriven-effectful-examples/postgres/EventMigration.hs diff --git a/domaindriven-core/src/Data/ShapeCoerce.hs b/domaindriven-core/src/Data/ShapeCoerce.hs index 8d3ba5b..f962869 100644 --- a/domaindriven-core/src/Data/ShapeCoerce.hs +++ b/domaindriven-core/src/Data/ShapeCoerce.hs @@ -10,7 +10,8 @@ import GHC.Generics import GHC.TypeLits import Prelude -gshapeCoerce :: forall a b. (Generic a, Generic b, GShapeCoercible a b (Rep a) (Rep b)) => a -> b +gshapeCoerce + :: forall a b. (Generic a, Generic b, GShapeCoercible a b (Rep a) (Rep b)) => a -> b gshapeCoerce = to . gscoerce @a @b . from -- Though intuitively two types are coercible iff they are isomorphic let's be @@ -22,8 +23,8 @@ class ShapeCoercible a b where instance {-# OVERLAPPABLE #-} - (Generic a, Generic b, GShapeCoercible a b (Rep a) (Rep b)) => - ShapeCoercible a b + (Generic a, Generic b, GShapeCoercible a b (Rep a) (Rep b)) + => ShapeCoercible a b where shapeCoerce = to . gscoerce @a @b . from @@ -37,9 +38,11 @@ class GShapeCoercible x y a b where gscoerce :: a x -> b x instance - forall x y f1 f2 datatypeName a1 b1 c1 a2 b2 c2. - (GShapeCoercible x y f1 f2) => - GShapeCoercible x y + forall x y f1 f2 datatypeName a1 b1 c1 a2 b2 c2 + . GShapeCoercible x y f1 f2 + => GShapeCoercible + x + y (M1 D ('MetaData datatypeName a1 b1 c1) f1) (M1 D ('MetaData datatypeName a2 b2 c2) f2) where @@ -48,21 +51,25 @@ instance -- Better error for incompatible data types instance {-# OVERLAPPABLE #-} - forall x y f1 f2 datatypeName1 datatypeName2 a1 b1 c1 a2 b2 c2. - ( TypeError + forall x y f1 f2 datatypeName1 datatypeName2 a1 b1 c1 a2 b2 c2 + . TypeError ( 'Text "Cannot shapeCoerce between types:" - ':$$: 'Text " From: " ':<>: 'ShowType x - ':$$: 'Text " To: " ':<>: 'ShowType y - ':$$: 'Text "" - ':$$: 'Text "Reason: Incompatible data types" - ':$$: 'Text " From type: " ':<>: 'ShowType datatypeName1 - ':$$: 'Text " To type: " ':<>: 'ShowType datatypeName2 - ':$$: 'Text "" - ':$$: 'Text "Solution: Write instance `ShapeCoercible " - ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Incompatible data types" + ':$$: 'Text " From type: " ':<>: 'ShowType datatypeName1 + ':$$: 'Text " To type: " ':<>: 'ShowType datatypeName2 + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x + ':<>: 'Text " " + ':<>: 'ShowType y + ':<>: 'Text "`" ) - ) => - GShapeCoercible x y + => GShapeCoercible + x + y (M1 D ('MetaData datatypeName1 a1 b1 c1) f1) (M1 D ('MetaData datatypeName2 a2 b2 c2) f2) where @@ -70,8 +77,10 @@ instance -- Matching constructor names with same structure instance - (GShapeCoercible x y f1 f2) => - GShapeCoercible x y + GShapeCoercible x y f1 f2 + => GShapeCoercible + x + y (M1 C ('MetaCons constructorName b c) f1) (M1 C ('MetaCons constructorName b c) f2) where @@ -80,19 +89,25 @@ instance -- Same constructor name but different structure instance {-# OVERLAPPABLE #-} - forall x y f1 f2 name b1 c1 b2 c2. - ( TypeError + forall x y f1 f2 name b1 c1 b2 c2 + . TypeError ( 'Text "Cannot shapeCoerce between types:" - ':$$: 'Text " From: " ':<>: 'ShowType x - ':$$: 'Text " To: " ':<>: 'ShowType y - ':$$: 'Text "" - ':$$: 'Text "Reason: Constructor " ':<>: 'ShowType name ':<>: 'Text " has different field structures" - ':$$: 'Text "" - ':$$: 'Text "Solution: Write instance `ShapeCoercible " - ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Constructor " + ':<>: 'ShowType name + ':<>: 'Text " has different field structures" + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x + ':<>: 'Text " " + ':<>: 'ShowType y + ':<>: 'Text "`" ) - ) => - GShapeCoercible x y + => GShapeCoercible + x + y (M1 C ('MetaCons name b1 c1) f1) (M1 C ('MetaCons name b2 c2) f2) where @@ -101,28 +116,34 @@ instance -- Different constructor names instance {-# OVERLAPPABLE #-} - forall x y f1 f2 cName1 cName2 b1 c1 b2 c2. - ( TypeError + forall x y f1 f2 cName1 cName2 b1 c1 b2 c2 + . TypeError ( 'Text "Cannot shapeCoerce between types:" - ':$$: 'Text " From: " ':<>: 'ShowType x - ':$$: 'Text " To: " ':<>: 'ShowType y - ':$$: 'Text "" - ':$$: 'Text "Reason: Constructor name mismatch" - ':$$: 'Text " " ':<>: 'ShowType cName1 ':<>: 'Text " ≠ " ':<>: 'ShowType cName2 - ':$$: 'Text "" - ':$$: 'Text "Solution: Write instance `ShapeCoercible " - ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Constructor name mismatch" + ':$$: 'Text " " ':<>: 'ShowType cName1 ':<>: 'Text " ≠ " ':<>: 'ShowType cName2 + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x + ':<>: 'Text " " + ':<>: 'ShowType y + ':<>: 'Text "`" ) - ) => - GShapeCoercible x y + => GShapeCoercible + x + y (M1 C ('MetaCons cName1 b1 c1) f1) (M1 C ('MetaCons cName2 b2 c2) f2) where gscoerce = error "unreachable" instance - (GShapeCoercible x y f1 f2) => - GShapeCoercible x y + GShapeCoercible x y f1 f2 + => GShapeCoercible + x + y (M1 S ('MetaSel selectorName a1 b1 c1) f1) (M1 S ('MetaSel selectorName a2 b2 c2) f2) where @@ -131,35 +152,39 @@ instance -- Instance for mismatched selector names instance {-# OVERLAPPABLE #-} - forall x y f1 f2 name1 name2 a1 b1 c1 a2 b2 c2. - ( TypeError + forall x y f1 f2 name1 name2 a1 b1 c1 a2 b2 c2 + . TypeError ( 'Text "Cannot shapeCoerce between types:" - ':$$: 'Text " From: " ':<>: 'ShowType x - ':$$: 'Text " To: " ':<>: 'ShowType y - ':$$: 'Text "" - ':$$: 'Text "Reason: Field name mismatch" - ':$$: 'Text " Expected: " ':<>: 'ShowType name1 - ':$$: 'Text " But got: " ':<>: 'ShowType name2 - ':$$: 'Text "" - ':$$: 'Text "Solution: Write instance `ShapeCoercible " - ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Field name mismatch" + ':$$: 'Text " Expected: " ':<>: 'ShowType name1 + ':$$: 'Text " But got: " ':<>: 'ShowType name2 + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x + ':<>: 'Text " " + ':<>: 'ShowType y + ':<>: 'Text "`" ) - ) => - GShapeCoercible x y + => GShapeCoercible + x + y (M1 S ('MetaSel name1 a1 b1 c1) f1) (M1 S ('MetaSel name2 a2 b2 c2) f2) where gscoerce = error "unreachable" instance - (GShapeCoercible x y a1 a2, GShapeCoercible x y b1 b2) => - GShapeCoercible x y (a1 :*: b1) (a2 :*: b2) + (GShapeCoercible x y a1 a2, GShapeCoercible x y b1 b2) + => GShapeCoercible x y (a1 :*: b1) (a2 :*: b2) where gscoerce (a :*: b) = gscoerce @x @y a :*: gscoerce @x @y b instance - (GShapeCoercible x y a1 a2, GShapeCoercible x y b1 b2) => - GShapeCoercible x y (a1 :+: b1) (a2 :+: b2) + (GShapeCoercible x y a1 a2, GShapeCoercible x y b1 b2) + => GShapeCoercible x y (a1 :+: b1) (a2 :+: b2) where gscoerce (L1 a) = L1 $ gscoerce @x @y a gscoerce (R1 b) = R1 $ gscoerce @x @y b @@ -167,159 +192,176 @@ instance -- Single constructor vs sum type (left to right) instance {-# OVERLAPPABLE #-} - forall x y c name b p f rest. - ( TypeError + forall x y c name b p f rest + . TypeError ( 'Text "Cannot shapeCoerce between types:" - ':$$: 'Text " From: " ':<>: 'ShowType x - ':$$: 'Text " To: " ':<>: 'ShowType y - ':$$: 'Text "" - ':$$: 'Text "Reason: Left side has a single constructor but right side is a sum type" - ':$$: 'Text "Left constructor: " ':<>: 'ShowType name - ':$$: 'Text "Right side: Multiple constructors (sum type)" - ':$$: 'Text "" - ':$$: 'Text "Solution: Write instance `ShapeCoercible " - ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Left side has a single constructor but right side is a sum type" + ':$$: 'Text "Left constructor: " ':<>: 'ShowType name + ':$$: 'Text "Right side: Multiple constructors (sum type)" + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x + ':<>: 'Text " " + ':<>: 'ShowType y + ':<>: 'Text "`" ) - ) => - GShapeCoercible x y (M1 C ('MetaCons name b p) f) (c :+: rest) + => GShapeCoercible x y (M1 C ('MetaCons name b p) f) (c :+: rest) where gscoerce = error "unreachable" -- Sum type vs single constructor (right to left) instance {-# OVERLAPPABLE #-} - forall x y c name b p f rest. - ( TypeError + forall x y c name b p f rest + . TypeError ( 'Text "Cannot shapeCoerce between types:" - ':$$: 'Text " From: " ':<>: 'ShowType x - ':$$: 'Text " To: " ':<>: 'ShowType y - ':$$: 'Text "" - ':$$: 'Text "Reason: Left side is a sum type but right side has a single constructor" - ':$$: 'Text "Right constructor: " ':<>: 'ShowType name - ':$$: 'Text "" - ':$$: 'Text "Solution: Write instance `ShapeCoercible " - ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Left side is a sum type but right side has a single constructor" + ':$$: 'Text "Right constructor: " ':<>: 'ShowType name + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x + ':<>: 'Text " " + ':<>: 'ShowType y + ':<>: 'Text "`" ) - ) => - GShapeCoercible x y (c :+: rest) (M1 C ('MetaCons name b p) f) + => GShapeCoercible x y (c :+: rest) (M1 C ('MetaCons name b p) f) where gscoerce = error "unreachable" - instance GShapeCoercible x y U1 U1 where gscoerce = id -- Better error for U1 vs field mismatch instance {-# OVERLAPPABLE #-} - forall x y name a b c t. - ( TypeError + forall x y name a b c t + . TypeError ( 'Text "Cannot shapeCoerce between types:" - ':$$: 'Text " From: " ':<>: 'ShowType x - ':$$: 'Text " To: " ':<>: 'ShowType y - ':$$: 'Text "" - ':$$: 'Text "Reason: Constructor has no fields but expected field: " ':<>: 'ShowType name - ':$$: 'Text "" - ':$$: 'Text "Solution: Write instance `ShapeCoercible " - ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Constructor has no fields but expected field: " ':<>: 'ShowType name + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x + ':<>: 'Text " " + ':<>: 'ShowType y + ':<>: 'Text "`" ) - ) => - GShapeCoercible x y U1 (M1 S ('MetaSel name a b c) t) + => GShapeCoercible x y U1 (M1 S ('MetaSel name a b c) t) where gscoerce = error "unreachable" -- Better error for field vs U1 mismatch instance {-# OVERLAPPABLE #-} - forall x y name a b c t. - ( TypeError + forall x y name a b c t + . TypeError ( 'Text "Cannot shapeCoerce between types:" - ':$$: 'Text " From: " ':<>: 'ShowType x - ':$$: 'Text " To: " ':<>: 'ShowType y - ':$$: 'Text "" - ':$$: 'Text "Reason: Constructor has field " ':<>: 'ShowType name ':<>: 'Text " but none expected" - ':$$: 'Text "" - ':$$: 'Text "Solution: Write instance `ShapeCoercible " - ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Constructor has field " + ':<>: 'ShowType name + ':<>: 'Text " but none expected" + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x + ':<>: 'Text " " + ':<>: 'ShowType y + ':<>: 'Text "`" ) - ) => - GShapeCoercible x y (M1 S ('MetaSel name a b c) t) U1 + => GShapeCoercible x y (M1 S ('MetaSel name a b c) t) U1 where gscoerce = error "unreachable" -- Instance for U1 vs product (fields) instance {-# OVERLAPPABLE #-} - forall x y a b. - ( TypeError + forall x y a b + . TypeError ( 'Text "Cannot shapeCoerce between types:" - ':$$: 'Text " From: " ':<>: 'ShowType x - ':$$: 'Text " To: " ':<>: 'ShowType y - ':$$: 'Text "" - ':$$: 'Text "Reason: Constructor has no fields but expected multiple fields" - ':$$: 'Text "" - ':$$: 'Text "Solution: Write instance `ShapeCoercible " - ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Constructor has no fields but expected multiple fields" + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x + ':<>: 'Text " " + ':<>: 'ShowType y + ':<>: 'Text "`" ) - ) => - GShapeCoercible x y U1 (a :*: b) + => GShapeCoercible x y U1 (a :*: b) where gscoerce = error "unreachable" -- Instance for product vs U1 instance {-# OVERLAPPABLE #-} - forall x y a b. - ( TypeError + forall x y a b + . TypeError ( 'Text "Cannot shapeCoerce between types:" - ':$$: 'Text " From: " ':<>: 'ShowType x - ':$$: 'Text " To: " ':<>: 'ShowType y - ':$$: 'Text "" - ':$$: 'Text "Reason: Constructor has fields but none expected" - ':$$: 'Text "" - ':$$: 'Text "Solution: Write instance `ShapeCoercible " - ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Constructor has fields but none expected" + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x + ':<>: 'Text " " + ':<>: 'ShowType y + ':<>: 'Text "`" ) - ) => - GShapeCoercible x y (a :*: b) U1 + => GShapeCoercible x y (a :*: b) U1 where gscoerce = error "unreachable" -- Instance for single field vs product (multiple fields) instance {-# OVERLAPPABLE #-} - forall x y s meta f rest. - ( TypeError + forall x y s meta f rest + . TypeError ( 'Text "Cannot shapeCoerce between types:" - ':$$: 'Text " From: " ':<>: 'ShowType x - ':$$: 'Text " To: " ':<>: 'ShowType y - ':$$: 'Text "" - ':$$: 'Text "Reason: Field count mismatch (single field vs multiple fields)" - ':$$: 'Text "" - ':$$: 'Text "Solution: Write instance `ShapeCoercible " - ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Field count mismatch (single field vs multiple fields)" + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x + ':<>: 'Text " " + ':<>: 'ShowType y + ':<>: 'Text "`" ) - ) => - GShapeCoercible x y (M1 S meta f) (s :*: rest) + => GShapeCoercible x y (M1 S meta f) (s :*: rest) where gscoerce = error "unreachable" -- Instance for product vs single field instance {-# OVERLAPPABLE #-} - forall x y s meta f rest. - ( TypeError + forall x y s meta f rest + . TypeError ( 'Text "Cannot shapeCoerce between types:" - ':$$: 'Text " From: " ':<>: 'ShowType x - ':$$: 'Text " To: " ':<>: 'ShowType y - ':$$: 'Text "" - ':$$: 'Text "Reason: Field count mismatch (multiple fields vs single field)" - ':$$: 'Text "" - ':$$: 'Text "Solution: Write instance `ShapeCoercible " - ':<>: 'ShowType x ':<>: 'Text " " ':<>: 'ShowType y ':<>: 'Text "`" + ':$$: 'Text " From: " ':<>: 'ShowType x + ':$$: 'Text " To: " ':<>: 'ShowType y + ':$$: 'Text "" + ':$$: 'Text "Reason: Field count mismatch (multiple fields vs single field)" + ':$$: 'Text "" + ':$$: 'Text "Solution: Write instance `ShapeCoercible " + ':<>: 'ShowType x + ':<>: 'Text " " + ':<>: 'ShowType y + ':<>: 'Text "`" ) - ) => - GShapeCoercible x y (s :*: rest) (M1 S meta f) + => GShapeCoercible x y (s :*: rest) (M1 S meta f) where gscoerce = error "unreachable" @@ -327,8 +369,7 @@ instance GShapeCoercible x y (M1 S s (Rec0 ())) U1 where gscoerce _ = U1 instance - (ShapeCoercible c1 c2) => - GShapeCoercible x y (Rec0 c1) (Rec0 c2) + ShapeCoercible c1 c2 + => GShapeCoercible x y (Rec0 c1) (Rec0 c2) where gscoerce (K1 x) = K1 $ shapeCoerce x - diff --git a/domaindriven-core/src/DomainDriven/Persistance/Class.hs b/domaindriven-core/src/DomainDriven/Persistance/Class.hs index 7591bfb..04dc848 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Class.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Class.hs @@ -9,7 +9,9 @@ module DomainDriven.Persistance.Class where import Control.DeepSeq (NFData) import Control.Monad.Reader import Data.Aeson +import Data.Hashable (Hashable) import Data.Kind +import Data.Text (Text) import Data.Time import Data.UUID (UUID) import GHC.Generics (Generic) @@ -18,8 +20,6 @@ import Streamly.Data.Stream.Prelude (Stream) import System.Random import UnliftIO import Prelude -import Data.Text (Text) -import Data.Hashable (Hashable) data NoIndex = NoIndex deriving (Show, Eq, Ord, Generic, Hashable) @@ -37,7 +37,6 @@ class ReadModel p where getEventList :: p -> Index p -> IO [Stored (Event p)] getEventStream :: HasCallStack => p -> Index p -> Stream IO (Stored (Event p)) - class ReadModel p => WriteModel p where -- | Hook to call after model has been updated. -- This allows for setting up outgoing hooks in calling out to external systems. diff --git a/domaindriven-core/src/DomainDriven/Persistance/ForgetfulInMemory.hs b/domaindriven-core/src/DomainDriven/Persistance/ForgetfulInMemory.hs index ea09622..f2b3c8a 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/ForgetfulInMemory.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/ForgetfulInMemory.hs @@ -2,19 +2,20 @@ module DomainDriven.Persistance.ForgetfulInMemory where +import Data.Generics.Labels () +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM +import Data.Hashable (Hashable) +import Data.Maybe (fromMaybe) import DomainDriven.Persistance.Class import GHC.Generics (Generic) import Streamly.Data.Stream.Prelude qualified as Stream import UnliftIO -import Data.Maybe (fromMaybe) -import Data.HashMap.Strict (HashMap) -import Data.Hashable (Hashable) -import Data.Generics.Labels () -import Data.HashMap.Strict qualified as HM import Prelude createForgetful - :: forall index model event m. MonadIO m + :: forall index model event m + . MonadIO m => (model -> Stored event -> model) -> model -- ^ initial model @@ -41,9 +42,11 @@ instance Hashable index => ReadModel (ForgetfulInMemory model index event) where type Event (ForgetfulInMemory model index event) = event type Index (ForgetfulInMemory model index event) = index applyEvent = apply - getModel :: MonadIO m => ForgetfulInMemory model index event - -> index - -> m model + getModel + :: MonadIO m + => ForgetfulInMemory model index event + -> index + -> m model getModel ff index = HM.lookupDefault (seed ff) index <$> readIORef (stateRef ff) getEventList ff index = HM.lookupDefault [] index <$> readIORef (events ff) getEventStream ff index = @@ -60,7 +63,7 @@ instance Hashable index => WriteModel (ForgetfulInMemory model index event) wher model <- HM.lookupDefault (seed ff) index <$> readIORef (stateRef ff) storedEvs <- traverse toStored evs let newModel = foldl' (apply ff) model storedEvs - modifyIORef (events ff) - $ HM.alter (Just . (<> storedEvs) . fromMaybe []) index + modifyIORef (events ff) $ + HM.alter (Just . (<> storedEvs) . fromMaybe []) index modifyIORef (stateRef ff) $ HM.insert index newModel pure (newModel, storedEvs, returnFun) diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres.hs index 4c823c4..bd6f962 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres.hs @@ -13,9 +13,9 @@ import DomainDriven.Persistance.Postgres.Internal as X import DomainDriven.Persistance.Postgres.Types as X ( ChunkSize , EventMigration - , IsPgIndex (..) , EventTable (..) , EventTableBaseName , EventTableName + , IsPgIndex (..) , PreviousEventTableName ) diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs index 890c64f..350cd62 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs @@ -45,7 +45,6 @@ data LogEntry | WaitForConnectionDuration NominalDiffTime OneLineCallStack deriving (Show, Generic) - newtype OneLineCallStack = OneLineCallStack CallStack instance Show OneLineCallStack where @@ -635,7 +634,7 @@ instance (IsPgIndex i, ToJSON e, FromJSON e) => WriteModel (PostgresEvent i m e) transactionalUpdate pg index cmd = withRunInIO $ \runInIO -> withIOTrans pg $ \pgt -> withExclusiveLock pgt index $ do - --m <- getModel' pgt index + -- m <- getModel' pgt index (returnFun, evs) <- runInIO cmd NumberedModel m' _ <- getCurrentState pg index storedEvs <- traverse toStored evs diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Migration.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Migration.hs index aaec80a..fda3839 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Migration.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Migration.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} + module DomainDriven.Persistance.Postgres.Migration where import Control.Monad @@ -21,7 +22,7 @@ defaultChunkSize = 100 migrateValue1to1 :: forall index - . IsPgIndex index + . IsPgIndex index => Connection -> PreviousEventTableName -> EventTableName @@ -31,7 +32,7 @@ migrateValue1to1 = migrateValue1to1' @index defaultChunkSize migrateValue1to1' :: forall index - . IsPgIndex index + . IsPgIndex index => ChunkSize -> Connection -> PreviousEventTableName @@ -132,8 +133,6 @@ migrate1toManyWithState' chunkSize conn prevTName tName f initialState = do events ) - - fetchAllIndices :: forall index . IsPgIndex index diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Types.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Types.hs index 678eb2d..a7baa56 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Types.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Types.hs @@ -2,10 +2,12 @@ module DomainDriven.Persistance.Postgres.Types where import Control.Monad.Catch import Data.Aeson +import Data.Hashable (Hashable) import Data.Int -import Data.Text qualified as T -import Data.String import Data.Pool.Introspection as Pool +import Data.String +import Data.Text (Text) +import Data.Text qualified as T import Data.Time import Data.Typeable import Data.UUID (UUID) @@ -14,8 +16,6 @@ import Database.PostgreSQL.Simple qualified as PG import Database.PostgreSQL.Simple.FromField qualified as FF import DomainDriven.Persistance.Class import GHC.Generics (Generic) -import Data.Hashable (Hashable) -import Data.Text (Text) import Prelude data PersistanceError diff --git a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs index 442c0b8..910a486 100644 --- a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs +++ b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs @@ -12,12 +12,12 @@ import Data.List qualified as L import Data.Set (Set) import Data.Set qualified as Set import Data.String (fromString) +import Data.Text qualified as T import Data.Time import Data.Traversable import Data.UUID (UUID, nil) import Data.UUID.V4 qualified as V4 import Database.PostgreSQL.Simple -import Data.Text qualified as T import DomainDriven.Persistance.Class import DomainDriven.Persistance.Postgres import DomainDriven.Persistance.Postgres.Internal @@ -31,7 +31,16 @@ import GHC.Generics (Generic) import GHC.IO.Unsafe (unsafePerformIO) import Streamly.Data.Stream.Prelude qualified as Stream import Test.Hspec -import UnliftIO (TVar, atomically, concurrently, modifyTVar, newTVarIO, readTVarIO, try, forConcurrently) +import UnliftIO + ( TVar + , atomically + , concurrently + , forConcurrently + , modifyTVar + , newTVarIO + , readTVarIO + , try + ) import UnliftIO.Pool import Prelude @@ -86,12 +95,21 @@ applyTestEvent m ev = case storedEvent ev of SubtractOne -> m - 1 Reset -> 0 -noHook :: PostgresEvent NoIndex TestModel TestEvent - -> NoIndex -> TestModel -> [Stored TestEvent] -> IO () +noHook + :: PostgresEvent NoIndex TestModel TestEvent + -> NoIndex + -> TestModel + -> [Stored TestEvent] + -> IO () noHook _ _ _ _ = pure () setupPersistance - :: (PostgresEvent NoIndex TestModel TestEvent -> NoIndex -> TestModel -> [Stored TestEvent] -> IO ()) + :: ( PostgresEvent NoIndex TestModel TestEvent + -> NoIndex + -> TestModel + -> [Stored TestEvent] + -> IO () + ) -> ((PostgresEvent NoIndex TestModel TestEvent, Pool Connection) -> IO ()) -> IO () setupPersistance postHook test = do @@ -120,7 +138,6 @@ setupPersistanceIndexed test = do p <- postgresWriteModel pool eventTable applyTestEvent 0 test (p{chunkSize = 2}, pool) - mkTestConn :: IO Connection mkTestConn = connect $ @@ -148,8 +165,6 @@ tableNames et = case et of MigrateUsing _ next -> getEventTableName et : tableNames next InitialVersion{} -> [getEventTableName et] - - writeEventsSpec :: SpecWith (PostgresEvent NoIndex TestModel TestEvent, Pool Connection) writeEventsSpec = describe "queryEvents" $ do let ev1 :: Stored TestEvent @@ -208,8 +223,8 @@ indexedSpec = describe "Indexed models" $ do it "Updates to different indices can be done in parallel" $ \(p, _pool) -> do -- This may fail in GHCI. Run it with stack test. - let testCmd :: Int -> IO (TestModel -> TestModel, [TestEvent]) - testCmd i = do + let testCmd :: Int -> IO (TestModel -> TestModel, [TestEvent]) + testCmd i = do threadDelay 100000 -- 0.1s delay pure (id, replicate i AddOne) t0 <- getCurrentTime @@ -220,14 +235,14 @@ indexedSpec = describe "Indexed models" $ do t1 <- getCurrentTime models `shouldSatisfy` (== 20) . length - models `shouldSatisfy` (== [1,2..20]) . L.sort + models `shouldSatisfy` (== [1, 2 .. 20]) . L.sort print $ diffUTCTime t1 t0 diffUTCTime t1 t0 `shouldSatisfy` (> 0.1) diffUTCTime t1 t0 `shouldSatisfy` (< 1.9) it "Updates to same index are done sequentially" $ \(p, _pool) -> do let testCmd :: IO (TestModel -> TestModel, [TestEvent]) - testCmd = do + testCmd = do threadDelay 100000 -- 0.1s delay pure (id, [AddOne, AddOne]) t0 <- getCurrentTime @@ -237,12 +252,11 @@ indexedSpec = describe "Indexed models" $ do t1 <- getCurrentTime - models `shouldSatisfy` (== 20) . length - models `shouldSatisfy` (== [2,4..40]) . L.sort + models `shouldSatisfy` (== 20) . length + models `shouldSatisfy` (== [2, 4 .. 40]) . L.sort print $ diffUTCTime t1 t0 diffUTCTime t1 t0 `shouldSatisfy` (> 20 * 0.1) - streamingSpec :: SpecWith (PostgresEvent NoIndex TestModel TestEvent, Pool Connection) streamingSpec = describe "steaming" $ do it "getEventList and getEventStream yields the same result" $ \(p, pool) -> do @@ -332,7 +346,8 @@ migrationSpec = describe "migrate1to1" $ do AddOne (UTCTime (fromGregorian 2020 10 15) 0) uuid - withResource pool + withResource + pool (\conn -> writeEvents conn (getEventTableName eventTable) NoIndex [ev]) `shouldThrow` (== FatalError) . sqlExecStatus @@ -371,7 +386,8 @@ migrationSpec = describe "migrate1to1" $ do brokenExists `shouldBe` False _ -> fail "Unexpectedly lacking table versions!" -migrationConcurrencySpec :: SpecWith (PostgresEvent NoIndex TestModel TestEvent, Pool Connection) +migrationConcurrencySpec + :: SpecWith (PostgresEvent NoIndex TestModel TestEvent, Pool Connection) migrationConcurrencySpec = describe "Event table is locked during migration" $ do it "migrate1to1" $ \(m0, pool) -> migrationTest m0 pool mig1to1 it "migrate1toMany" $ \(m0, pool) -> migrationTest m0 pool mig1toMany @@ -383,8 +399,8 @@ migrationConcurrencySpec = describe "Event table is locked during migration" $ d -> EventMigration -> IO () migrationTest m0 pool mig = do - let cmd :: IO (Int -> Int, [TestEvent]) - cmd = pure (id, [AddOne]) + let cmd :: IO (Int -> Int, [TestEvent]) + cmd = pure (id, [AddOne]) i <- replicateM 5 (runCmd m0 NoIndex cmd) length i `shouldBe` 5 diff --git a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal index 7b5b628..b889ece 100644 --- a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal +++ b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal @@ -26,6 +26,9 @@ source-repository head executable postgres-example main-is: Main.hs other-modules: + Event.V1 + Event.V2 + EventMigration Paths_domaindriven_effectful_examples hs-source-dirs: postgres @@ -63,7 +66,7 @@ executable postgres-example TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wno-unused-packages -fplugin=Effectful.Plugin -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wno-unused-packages -Wno-partial-fields -fplugin=Effectful.Plugin -threaded -rtsopts -with-rtsopts=-N build-depends: aeson , base @@ -118,7 +121,7 @@ executable simple-example TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wno-unused-packages -fplugin=Effectful.Plugin -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wno-unused-packages -Wno-partial-fields -fplugin=Effectful.Plugin -threaded -rtsopts -with-rtsopts=-N build-depends: aeson , base diff --git a/domaindriven-effectful-examples/package.yaml b/domaindriven-effectful-examples/package.yaml index e398720..6699c2f 100644 --- a/domaindriven-effectful-examples/package.yaml +++ b/domaindriven-effectful-examples/package.yaml @@ -66,6 +66,7 @@ ghc-options: - -Wredundant-constraints - -Wincomplete-patterns - -Wno-unused-packages +- -Wno-partial-fields - -fplugin=Effectful.Plugin executables: diff --git a/domaindriven-effectful-examples/postgres/Event/V1.hs b/domaindriven-effectful-examples/postgres/Event/V1.hs new file mode 100644 index 0000000..fb0b358 --- /dev/null +++ b/domaindriven-effectful-examples/postgres/Event/V1.hs @@ -0,0 +1,28 @@ +module Event.V1 where + +import Data.Text (Text) +import Data.UUID (UUID) +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) +import Prelude + +type UserId = UUID + +data Event + = UserEvent UserId UserEvent + | InventoryEvent InventoryEvent + deriving (Show, Generic, FromJSON, ToJSON) + +data UserEvent + = UserCreated {userName :: Text} + | UserNameChanged {newUserName :: Text} + deriving (Show, Generic, FromJSON, ToJSON) + +data InventoryEvent + = ItemAdded + { itemId :: UUID + , itemName :: Text + , quantity :: Int + } + | ItemRenamed {itemId :: UUID, itemName :: Text} + deriving (Show, Generic, FromJSON, ToJSON) diff --git a/domaindriven-effectful-examples/postgres/Event/V2.hs b/domaindriven-effectful-examples/postgres/Event/V2.hs new file mode 100644 index 0000000..afba5c0 --- /dev/null +++ b/domaindriven-effectful-examples/postgres/Event/V2.hs @@ -0,0 +1,30 @@ +module Event.V2 where + +import Data.Text (Text) +import Data.UUID (UUID) +import GHC.Generics (Generic) +import Prelude +import Data.Aeson (FromJSON, ToJSON) + +type UserId = UUID + +data Event + = UserEvent UserId UserEvent + | InventoryEvent InventoryEvent + deriving (Show, Generic, FromJSON, ToJSON) + +data UserEvent + = UserCreated {userName :: Text} + | UserNameChanged {newUserName :: Text} + | UserDeleted + deriving (Show, Generic, FromJSON, ToJSON) + +data InventoryEvent + = ItemAdded + { itemId :: UUID + , itemName :: Text + , quantity :: Int + } + | ItemRenamed {itemId :: UUID, itemName :: Text} + deriving (Show, Generic, FromJSON, ToJSON) + diff --git a/domaindriven-effectful-examples/postgres/EventMigration.hs b/domaindriven-effectful-examples/postgres/EventMigration.hs new file mode 100644 index 0000000..ae4b1bc --- /dev/null +++ b/domaindriven-effectful-examples/postgres/EventMigration.hs @@ -0,0 +1,58 @@ +{-# options_GHC -Wno-orphans #-} +module EventMigration where + +import Prelude +import Data.ShapeCoerce +import DomainDriven.Persistance.Class +import DomainDriven.Persistance.Postgres +import Database.PostgreSQL.Simple (Connection) +import DomainDriven.Persistance.Postgres.Migration +import Event.V1 qualified as V1 +import Event.V2 qualified as V2 + + + +fixEvent :: Stored V1.Event -> Stored V2.Event +fixEvent = shapeCoerce + +-- /home/tommy/git/domaindriven/domaindriven-effectful-examples/postgres/EventMigra +-- tion.hs:16:12: error: [GHC-64725] +-- • Cannot shapeCoerce between types: +-- From: V1.UserEvent +-- To: V2.UserEvent +-- +-- Reason: Left side has a single constructor but right side is a sum type +-- Left constructor: "UserNameChanged" +-- Right side: Multiple constructors (sum type) +-- +-- Solution: Write instance `ShapeCoercible V1.UserEvent V2.UserEvent` +-- • In the expression: shapeCoerce +-- In an equation for ‘fixEvent’: fixEvent = shapeCoerce +-- | +-- 16 | fixEvent = shapeCoerce +-- | ^^^^^^^^^^^ +-- -- | V2.UserEvent has a new constructor + +instance ShapeCoercible V1.UserEvent V2.UserEvent where + shapeCoerce = \case + V1.UserCreated name -> V2.UserCreated name + V1.UserNameChanged name -> V2.UserNameChanged name + +migrate :: + PreviousEventTableName -> + EventTableName -> + Connection -> + IO () +migrate prevEtname etName conn = do + migrate1to1 @NoIndex + conn + prevEtname + etName + fixEvent + +eventTable :: EventTable +eventTable = MigrateUsing migrate + $ InitialVersion "my_events" + + + diff --git a/domaindriven-effectful-examples/postgres/Main.hs b/domaindriven-effectful-examples/postgres/Main.hs index 2717d6e..9dceb41 100644 --- a/domaindriven-effectful-examples/postgres/Main.hs +++ b/domaindriven-effectful-examples/postgres/Main.hs @@ -2,10 +2,10 @@ module Main where import Control.Monad (when) import Data.Aeson +import Database.PostgreSQL.Simple (connectPostgreSQL) import DomainDriven.Effectful import DomainDriven.Effectful.Interpreter.Postgres import Effectful hiding ((:>)) -import Database.PostgreSQL.Simple (connectPostgreSQL) import Effectful qualified import Effectful.Error.Static import Network.Wai.Handler.Warp (run) @@ -77,7 +77,8 @@ counterServer = -- Create the servant application. -- Here we have to run all the effects and transform it to Servant's Handler monad. -------------------------------------------------------------------------------- -mkCounterServer :: PostgresEvent NoIndex CounterModel CounterEvent +mkCounterServer + :: PostgresEvent NoIndex CounterModel CounterEvent -> Application mkCounterServer backend = genericServeT runEffects counterServer @@ -102,6 +103,7 @@ mkCounterServer backend = eventTable :: EventTable eventTable = InitialVersion "counter_events" + -------------------------------------------------------------------------------- -- Run the server -------------------------------------------------------------------------------- @@ -111,12 +113,15 @@ main = do putStrLn $ "Running Effectful counter on port " <> show port -- Initialize the in-memory backend - connectionPool <- simplePool - $ connectPostgreSQL "host=localhost port=5432 user=postgres dbname=domaindriven password=postgres" - backend <- postgresWriteModel - connectionPool - eventTable - applyEvent - (0 :: CounterModel) + connectionPool <- + simplePool $ + connectPostgreSQL + "host=localhost port=5432 user=postgres dbname=domaindriven password=postgres" + backend <- + postgresWriteModel + connectionPool + eventTable + applyEvent + (0 :: CounterModel) -- Create and run the application run port $ mkCounterServer backend diff --git a/domaindriven-effectful-examples/simple/Main.hs b/domaindriven-effectful-examples/simple/Main.hs index da57b4f..48de08b 100644 --- a/domaindriven-effectful-examples/simple/Main.hs +++ b/domaindriven-effectful-examples/simple/Main.hs @@ -75,7 +75,9 @@ counterServer = -- Create the servant application. -- Here we have to run all the effects and transform it to Servant's Handler monad. -------------------------------------------------------------------------------- -mkCounterServer :: ForgetfulInMemory CounterModel NoIndex CounterEvent -> Application +mkCounterServer + :: ForgetfulInMemory CounterModel NoIndex CounterEvent + -> Application mkCounterServer backend = genericServeT runEffects counterServer where diff --git a/domaindriven-effectful/src/DomainDriven/Effectful.hs b/domaindriven-effectful/src/DomainDriven/Effectful.hs index 9900470..b616106 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful.hs @@ -1,13 +1,13 @@ module DomainDriven.Effectful ( -- * Domain configuration (re-exported) - module DomainDriven.Effectful.Domain + module DomainDriven.Effectful.Domain + -- * Effects and helpers , module X ) where -import DomainDriven.Persistance.Class as X (Indexed(..),NoIndex (..), Stored (..)) -import DomainDriven.Effectful.Domain import DomainDriven.Effectful.Aggregate as X +import DomainDriven.Effectful.Domain import DomainDriven.Effectful.Projection as X - +import DomainDriven.Persistance.Class as X (Indexed (..), NoIndex (..), Stored (..)) diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs index 8827c68..cff886a 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs @@ -4,21 +4,21 @@ module DomainDriven.Effectful.Aggregate where import Data.Kind (Type) +import Data.Type.Equality import DomainDriven.Effectful.Domain -import DomainDriven.Persistance.Class (NoIndex(..)) +import DomainDriven.Persistance.Class (NoIndex (..)) import Effectful -import Data.Type.Equality import Effectful.TH -- | The new Aggregate effect with a single domain parameter data Aggregate (domain :: Type) :: Effect where RunTransactionI :: DomainIndex domain - -> (Eff - es - ( DomainModel domain -> a - , [DomainEvent domain] - ) + -> ( Eff + es + ( DomainModel domain -> a + , [DomainEvent domain] + ) ) -> Aggregate domain (Eff es) a @@ -29,12 +29,12 @@ $(makeEffect ''Aggregate) runTransaction :: forall domain es a . Aggregate domain :> es - => DomainIndex domain ~ NoIndex - => ( Eff - es - ( DomainModel domain -> a - , [DomainEvent domain] - ) - ) - -> Eff es a + => DomainIndex domain ~ NoIndex + => ( Eff + es + ( DomainModel domain -> a + , [DomainEvent domain] + ) + ) + -> Eff es a runTransaction = runTransactionI NoIndex diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs index 332389b..4cfc1ad 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs @@ -1,31 +1,32 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} module DomainDriven.Effectful.Interpreter.InMemory ( module DomainDriven.Effectful.Interpreter.InMemory - , createForgetful, ForgetfulInMemory + , createForgetful + , ForgetfulInMemory ) where +import Data.Hashable (Hashable) import DomainDriven.Effectful.Aggregate -import DomainDriven.Effectful.Projection import DomainDriven.Effectful.Domain +import DomainDriven.Effectful.Projection import DomainDriven.Persistance.Class (WriteModel) -import qualified DomainDriven.Persistance.Class as P +import DomainDriven.Persistance.Class qualified as P import DomainDriven.Persistance.ForgetfulInMemory import Effectful import Effectful.Dispatch.Dynamic -import Data.Hashable (Hashable) import Prelude -- | Run the Projection' effect using an in-memory backend (new domain API) runProjectionInMemory :: forall domain es a - . ( Hashable (DomainIndex domain), IOE :> es) + . (Hashable (DomainIndex domain), IOE :> es) => ForgetfulInMemory (DomainModel domain) (DomainIndex domain) (DomainEvent domain) -> Eff (Projection domain : es) a -> Eff es a @@ -37,7 +38,8 @@ runProjectionInMemory backend = interpret $ \_ -> \case runAggregateInMemory :: forall domain es a . ( IOE :> es - , WriteModel (ForgetfulInMemory (DomainModel domain) (DomainIndex domain) (DomainEvent domain)) + , WriteModel + (ForgetfulInMemory (DomainModel domain) (DomainIndex domain) (DomainEvent domain)) ) => ForgetfulInMemory (DomainModel domain) (DomainIndex domain) (DomainEvent domain) -> Eff (Aggregate domain : es) a @@ -45,6 +47,7 @@ runAggregateInMemory runAggregateInMemory backend = interpret $ \env -> \case RunTransactionI idx cmd -> do localSeqUnlift env $ \unlift -> do - (model', _, returnFun) <- P.transactionalUpdate backend idx - $ unlift cmd + (model', _, returnFun) <- + P.transactionalUpdate backend idx $ + unlift cmd pure $ returnFun model' diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs index 9a01e13..221da70 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs @@ -30,7 +30,7 @@ runProjectionPostgres , IsPgIndex index , index ~ (DomainIndex domain) ) - => PostgresEvent (DomainIndex domain) (DomainModel domain) (DomainEvent domain) + => PostgresEvent (DomainIndex domain) (DomainModel domain) (DomainEvent domain) -> Eff (Projection domain : es) a -> Eff es a runProjectionPostgres backend = interpret $ \_ -> \case @@ -42,9 +42,9 @@ runAggregatePostgres :: forall domain es a index . ( IOE :> es , index ~ (DomainIndex domain) - , WriteModel (PostgresEvent (DomainIndex domain) (DomainModel domain) (DomainEvent domain)) + , WriteModel (PostgresEvent (DomainIndex domain) (DomainModel domain) (DomainEvent domain)) ) - => PostgresEvent (DomainIndex domain) (DomainModel domain) (DomainEvent domain) + => PostgresEvent (DomainIndex domain) (DomainModel domain) (DomainEvent domain) -> Eff (Aggregate domain : es) a -> Eff es a runAggregatePostgres backend = interpret $ \env -> \case diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs index b43150b..e0cf8d7 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs @@ -1,24 +1,27 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TemplateHaskell #-} module DomainDriven.Effectful.Projection where -import DomainDriven.Effectful.Domain -import DomainDriven.Persistance.Class (Stored, NoIndex(..)) import Data.Type.Equality +import DomainDriven.Effectful.Domain +import DomainDriven.Persistance.Class (NoIndex (..), Stored) import Effectful import Effectful.TH -- | The new Projection effect with a single domain parameter -- We use a proxy to carry the domain type explicitly -data Projection domain :: Effect where - GetModelI :: DomainIndex domain +data Projection domain :: Effect where + GetModelI + :: DomainIndex domain -> Projection domain m (DomainModel domain) - GetEventListI :: DomainIndex domain + GetEventListI + :: DomainIndex domain -> Projection domain m [Stored (DomainEvent domain)] + -- GetEventStream :: Projection domain m (Stream m (Stored (DomainEvent domain))) type instance DispatchOf (Projection domain) = 'Dynamic @@ -27,18 +30,17 @@ $(makeEffect ''Projection) getModel :: forall domain es - . (DomainIndex domain ~ NoIndex - , Projection domain :> es - ) + . ( DomainIndex domain ~ NoIndex + , Projection domain :> es + ) => Eff es (DomainModel domain) getModel = getModelI NoIndex -- | Get a list of all the events used to create the model (new domain-based API) getEventList :: forall domain es - . (DomainIndex domain ~ NoIndex - , Projection domain :> es - ) + . ( DomainIndex domain ~ NoIndex + , Projection domain :> es + ) => Eff es [Stored (DomainEvent domain)] getEventList = getEventListI NoIndex - diff --git a/domaindriven-effectful/src/DomainDriven/FieldNameAsPath.hs b/domaindriven-effectful/src/DomainDriven/FieldNameAsPath.hs index 2a0b769..6a23135 100644 --- a/domaindriven-effectful/src/DomainDriven/FieldNameAsPath.hs +++ b/domaindriven-effectful/src/DomainDriven/FieldNameAsPath.hs @@ -31,7 +31,6 @@ import Servant.Server.Internal.Delayed import Servant.Server.Internal.Router import Prelude - -- | Wrapper around the data structure containing the API and endpoint definitions. -- The endpoints name in the record will be added to the path. For example: -- ``` @@ -40,7 +39,7 @@ import Prelude -- } -- ``` -- Will result in a Post endpoint with path "something/increaseWith". -data FieldNameAsPathApi (mkApiRecord :: Type -> Type) +data FieldNameAsPathApi (mkApiRecord :: Type -> Type) class ApiTagFromLabel (mkApiRecord :: Type -> Type) where apiTagFromLabel :: String -> String @@ -54,12 +53,12 @@ newtype (mkServerRecord :: Type -> Type) (m :: Type -> Type) = FieldNameAsPathServer { unDomainDrivenServer - :: mkServerRecord (AsServerT m) + :: mkServerRecord (AsServerT m) } deriving newtype instance - GHC.Generic (mkServerRecord (AsServerT m)) - => GHC.Generic (FieldNameAsPathServer mkServerRecord m) + GHC.Generic (mkServerRecord (AsServerT m)) + => GHC.Generic (FieldNameAsPathServer mkServerRecord m) class DomainDrivenServerFields (mkApiRecord :: Type -> Type) (m :: Type -> Type) where recordOfServersFromFields @@ -100,14 +99,14 @@ class -> NP I (ServerTs apis m) -> NP I (ServerTs apis n) -instance FieldNamesInPathHasServers mkApiRecord '[] '[] context where +instance FieldNamesInPathHasServers mkApiRecord '[] '[] context where type ServerTs '[] m = '[] taggedSumOfRoutes _ _ = StaticRouter mempty mempty hoistTaggedServersWithContext _ Nil = Nil instance ( HasServer api context - , FieldNamesInPathHasServers mkApiRecord apis infos context + , FieldNamesInPathHasServers mkApiRecord apis infos context , KnownSymbol label , ApiTagFromLabel mkApiRecord ) @@ -126,32 +125,32 @@ instance $ route (Proxy @api) context $ (\(I server :* _) -> server) <$> delayedServers ) - ( taggedSumOfRoutes @mkApiRecord @apis @infos context $ + ( taggedSumOfRoutes @mkApiRecord @apis @infos context $ (\(_ :* servers) -> servers) <$> delayedServers ) hoistTaggedServersWithContext nt (I server :* servers) = I (hoistServerWithContext (Proxy @api) (Proxy @context) nt server) - :* hoistTaggedServersWithContext @mkApiRecord @apis @infos @context nt servers + :* hoistTaggedServersWithContext @mkApiRecord @apis @infos @context nt servers instance ( FieldNamesInPathHasServers mkApiRecord - (GenericRecordFields (mkApiRecord AsApi)) - (GenericRecordFieldInfos (mkApiRecord AsApi)) + (GenericRecordFields (mkApiRecord AsApi)) + (GenericRecordFieldInfos (mkApiRecord AsApi)) context - , forall m. DomainDrivenServerFields (mkApiRecord ) m + , forall m. DomainDrivenServerFields (mkApiRecord) m ) - => HasServer (FieldNameAsPathApi mkApiRecord ) context + => HasServer (FieldNameAsPathApi mkApiRecord) context where type - ServerT (FieldNameAsPathApi mkApiRecord ) m = - FieldNameAsPathServer mkApiRecord m + ServerT (FieldNameAsPathApi mkApiRecord) m = + FieldNameAsPathServer mkApiRecord m route _ context delayedServer = taggedSumOfRoutes @mkApiRecord - @(GenericRecordFields (mkApiRecord AsApi)) - @(GenericRecordFieldInfos (mkApiRecord AsApi)) + @(GenericRecordFields (mkApiRecord AsApi)) + @(GenericRecordFieldInfos (mkApiRecord AsApi)) context (recordOfServersToFields . unDomainDrivenServer <$> delayedServer) @@ -159,8 +158,8 @@ instance FieldNameAsPathServer . recordOfServersFromFields . hoistTaggedServersWithContext @mkApiRecord - @(GenericRecordFields (mkApiRecord AsApi)) - @(GenericRecordFieldInfos (mkApiRecord AsApi)) + @(GenericRecordFields (mkApiRecord AsApi)) + @(GenericRecordFieldInfos (mkApiRecord AsApi)) @context nt . recordOfServersToFields @@ -194,23 +193,23 @@ instance instance FieldNamesInPathHasOpenApi mkApiRecord - (GenericRecordFields (mkApiRecord AsApi)) - (GenericRecordFieldInfos (mkApiRecord AsApi)) - => HasOpenApi (FieldNameAsPathApi mkApiRecord ) + (GenericRecordFields (mkApiRecord AsApi)) + (GenericRecordFieldInfos (mkApiRecord AsApi)) + => HasOpenApi (FieldNameAsPathApi mkApiRecord) where toOpenApi _ = domainDrivenApiToOpenApi @mkApiRecord - @(GenericRecordFields (mkApiRecord AsApi)) - @(GenericRecordFieldInfos (mkApiRecord AsApi)) + @(GenericRecordFields (mkApiRecord AsApi)) + @(GenericRecordFieldInfos (mkApiRecord AsApi)) instance - ( GHC.Generic (FieldNameAsPathServer mkServerRecord m) - , GTo (FieldNameAsPathServer mkServerRecord m) - , ThrowAll (SOP I (GCode (FieldNameAsPathServer mkServerRecord m))) + ( GHC.Generic (FieldNameAsPathServer mkServerRecord m) + , GTo (FieldNameAsPathServer mkServerRecord m) + , ThrowAll (SOP I (GCode (FieldNameAsPathServer mkServerRecord m))) ) - => ThrowAll (FieldNameAsPathServer mkServerRecord m) + => ThrowAll (FieldNameAsPathServer mkServerRecord m) where - throwAll = gto . throwAll @(SOP I (GCode (FieldNameAsPathServer mkServerRecord m))) + throwAll = gto . throwAll @(SOP I (GCode (FieldNameAsPathServer mkServerRecord m))) class FieldNamesInPathHasClients @@ -283,32 +282,29 @@ instance , FieldNamesInPathHasClients m mkApiRecord - (GenericRecordFields (mkApiRecord AsApi)) - (GenericRecordFieldInfos (mkApiRecord AsApi)) - , forall n. DomainDrivenClientFields (mkApiRecord ) n + (GenericRecordFields (mkApiRecord AsApi)) + (GenericRecordFieldInfos (mkApiRecord AsApi)) + , forall n. DomainDrivenClientFields (mkApiRecord) n ) - => HasClient m (FieldNameAsPathApi mkApiRecord ) + => HasClient m (FieldNameAsPathApi mkApiRecord) where type - Client m (FieldNameAsPathApi mkApiRecord ) = - mkApiRecord (AsClientT m) + Client m (FieldNameAsPathApi mkApiRecord) = + mkApiRecord (AsClientT m) clientWithRoute _ _ = recordOfClientsFromFields . ( clientsWithRoute @m @mkApiRecord - @(GenericRecordFields (mkApiRecord AsApi)) - @(GenericRecordFieldInfos (mkApiRecord AsApi)) + @(GenericRecordFields (mkApiRecord AsApi)) + @(GenericRecordFieldInfos (mkApiRecord AsApi)) ) hoistClientMonad _ _ nt = recordOfClientsFromFields . hoistClientsMonad @m @mkApiRecord - @(GenericRecordFields (mkApiRecord AsApi)) - @(GenericRecordFieldInfos (mkApiRecord AsApi)) + @(GenericRecordFields (mkApiRecord AsApi)) + @(GenericRecordFieldInfos (mkApiRecord AsApi)) nt . recordOfClientsToFields - - - type family GenericRecordFields (record :: Type) :: [Type] where GenericRecordFields record = GenericRecordFields' (GCode record) From 7272c54e2620552c35e94c8b54088e027bfed60f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Sat, 13 Sep 2025 15:49:07 +0200 Subject: [PATCH 28/50] minimal intro --- domaindriven-effectful-examples/intro.txt | 9 +++++++++ domaindriven-effectful-examples/simple/Main.hs | 4 ++-- 2 files changed, 11 insertions(+), 2 deletions(-) create mode 100644 domaindriven-effectful-examples/intro.txt diff --git a/domaindriven-effectful-examples/intro.txt b/domaindriven-effectful-examples/intro.txt new file mode 100644 index 0000000..b21be1c --- /dev/null +++ b/domaindriven-effectful-examples/intro.txt @@ -0,0 +1,9 @@ + + +# DomainDriven + +## Design decisions + +- Avoid the complexity of ascynchronous event sourcing +- Convenient for the end user +- Easy to migrate events diff --git a/domaindriven-effectful-examples/simple/Main.hs b/domaindriven-effectful-examples/simple/Main.hs index 48de08b..8f1bb79 100644 --- a/domaindriven-effectful-examples/simple/Main.hs +++ b/domaindriven-effectful-examples/simple/Main.hs @@ -34,8 +34,6 @@ applyEvent i (Stored ev _timestamp _uuid) = case ev of Increase -> i + 1 Decrease -> i - 1 --- Define the domain, used to cary the type constraints -type CounterDomain = Domain CounterModel CounterEvent NoIndex -------------------------------------------------------------------------------- -- Use Servant to define the Commands @@ -51,6 +49,8 @@ data CounterAPI mode = CounterAPI -- Implement the server handlers using Effectful effects -------------------------------------------------------------------------------- +type CounterDomain = Domain CounterModel CounterEvent NoIndex + -- | Counter handlers using Effectful effects counterServer :: ( Projection CounterDomain Effectful.:> es From 8ef98194a5ba161a1447f9279af9d6ae83005401 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Mon, 15 Sep 2025 08:21:44 +0200 Subject: [PATCH 29/50] tmp --- domaindriven-effectful-examples/intro.txt | 2 -- .../simple/Main.hs | 29 ++++++++++++------- 2 files changed, 18 insertions(+), 13 deletions(-) diff --git a/domaindriven-effectful-examples/intro.txt b/domaindriven-effectful-examples/intro.txt index b21be1c..4895d79 100644 --- a/domaindriven-effectful-examples/intro.txt +++ b/domaindriven-effectful-examples/intro.txt @@ -1,5 +1,3 @@ - - # DomainDriven ## Design decisions diff --git a/domaindriven-effectful-examples/simple/Main.hs b/domaindriven-effectful-examples/simple/Main.hs index 8f1bb79..8c5122e 100644 --- a/domaindriven-effectful-examples/simple/Main.hs +++ b/domaindriven-effectful-examples/simple/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedRecordDot #-} module Main where import Control.Monad (when) @@ -16,23 +17,27 @@ import Prelude -------------------------------------------------------------------------------- -- Define the model -------------------------------------------------------------------------------- -type CounterModel = Int +data CounterModel = CounterModel + { counter :: Int + , previousCounter :: Int + } deriving (Show, Generic) + -------------------------------------------------------------------------------- -- Define events -------------------------------------------------------------------------------- data CounterEvent - = Increase - | Decrease + = CounterIncreased + | CounterDecreased deriving (Show) -------------------------------------------------------------------------------- -- Define event handler -------------------------------------------------------------------------------- applyEvent :: CounterModel -> Stored CounterEvent -> CounterModel -applyEvent i (Stored ev _timestamp _uuid) = case ev of - Increase -> i + 1 - Decrease -> i - 1 +applyEvent (CounterModel i _) (Stored ev _timestamp _uuid) = case ev of + CounterIncreased -> CounterModel (i + 1) i + CounterDecreased -> CounterModel (i - 1) i -------------------------------------------------------------------------------- @@ -60,15 +65,17 @@ counterServer => CounterAPI (AsServerT (Eff es)) counterServer = CounterAPI - { get = getModel + { get = do + CounterModel {counter} <- getModel + pure counter , increase = runTransaction do - pure (id, [Increase]) + pure (\a -> a.counter , [CounterIncreased]) , decrease = runTransaction do m <- getModel when - (m <= 0) + (m.counter <= 0) (throwError err422{errBody = "Counter cannot go below zero"}) - pure (id, [Decrease]) + pure (\a -> a.counter, [CounterDecreased]) } -------------------------------------------------------------------------------- @@ -108,7 +115,7 @@ main = do putStrLn $ "Running Effectful counter on port " <> show port -- Initialize the in-memory backend - backend <- createForgetful applyEvent 0 + backend <- createForgetful applyEvent (CounterModel 0 0) -- Create and run the application run port $ mkCounterServer backend From fd2d67e183e36c4f0e90c8950cd5d2da269cb5ee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Thu, 25 Sep 2025 08:09:29 +0200 Subject: [PATCH 30/50] upgrade lts and include missings deps --- .../domaindriven-effectful-examples.cabal | 2 ++ domaindriven-effectful-examples/package.yaml | 4 +++- stack.yaml | 6 +----- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal index b889ece..f6941aa 100644 --- a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal +++ b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal @@ -78,6 +78,8 @@ executable postgres-example , postgresql-simple , servant , servant-server + , text + , uuid , warp default-language: Haskell2010 diff --git a/domaindriven-effectful-examples/package.yaml b/domaindriven-effectful-examples/package.yaml index 6699c2f..e7ece96 100644 --- a/domaindriven-effectful-examples/package.yaml +++ b/domaindriven-effectful-examples/package.yaml @@ -98,8 +98,10 @@ executables: - domaindriven-core - domaindriven-effectful - effectful + - postgresql-simple - servant - servant-server + - uuid + - text - warp - - postgresql-simple diff --git a/stack.yaml b/stack.yaml index 8e13fb6..d72fae3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,14 +1,10 @@ -resolver: lts-24.9 +resolver: lts-24.12 packages: - domaindriven-core - domaindriven-effectful - domaindriven-effectful-examples extra-deps: - - openapi3-3.2.4 - - servant-auth-server-0.4.9.0 - - insert-ordered-containers-0.2.6 - - servant-openapi3-2.0.1.6 ghc-options: "$locals": -fwrite-ide-info From 346ef05deb7c28407133a9b57151c5a0711e862e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Fri, 26 Sep 2025 08:47:16 +0200 Subject: [PATCH 31/50] switch to using cabal --- cabal.project | 9 ++ domaindriven-core/domaindriven-core.cabal | 96 ++++++--------- domaindriven-core/package.yaml | 116 ------------------ .../domaindriven-effectful-examples.cabal | 88 +++++-------- domaindriven-effectful-examples/package.yaml | 107 ---------------- .../domaindriven-effectful.cabal | 55 +++++---- domaindriven-effectful/package.yaml | 93 -------------- stack.yaml | 21 ---- 8 files changed, 110 insertions(+), 475 deletions(-) create mode 100644 cabal.project delete mode 100644 domaindriven-core/package.yaml delete mode 100644 domaindriven-effectful-examples/package.yaml delete mode 100644 domaindriven-effectful/package.yaml delete mode 100644 stack.yaml diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..c57c0d0 --- /dev/null +++ b/cabal.project @@ -0,0 +1,9 @@ +packages: + domaindriven-core/ + domaindriven-effectful/ + domaindriven-effectful-examples/ + +-- Use Stackage LTS 24.2 as the main package source +import: https://www.stackage.org/lts-24.12/cabal.config + +with-compiler: ghc-9.10.3 diff --git a/domaindriven-core/domaindriven-core.cabal b/domaindriven-core/domaindriven-core.cabal index 8fef729..a6ef9c0 100644 --- a/domaindriven-core/domaindriven-core.cabal +++ b/domaindriven-core/domaindriven-core.cabal @@ -1,8 +1,4 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.38.1. --- --- see: https://github.com/sol/hpack +cabal-version: 3.12 name: domaindriven-core version: 0.5.0 @@ -12,9 +8,9 @@ category: Web homepage: https://github.com/tommyengstrom/domaindriven#readme bug-reports: https://github.com/tommyengstrom/domaindriven/issues author: Tommy Engström -maintainer: tommy@tommyengstrom.com -copyright: 2022 Tommy Engström -license: BSD3 +maintainer: tommy@succinct.se +copyright: 2025 Tommy Engström +license: BSD-3-Clause license-file: LICENSE build-type: Simple extra-source-files: @@ -25,19 +21,8 @@ source-repository head type: git location: https://github.com/tommyengstrom/domaindriven -library - exposed-modules: - Data.ShapeCoerce - DomainDriven.Persistance.Class - DomainDriven.Persistance.ForgetfulInMemory - DomainDriven.Persistance.Postgres - DomainDriven.Persistance.Postgres.Internal - DomainDriven.Persistance.Postgres.Migration - DomainDriven.Persistance.Postgres.Types - other-modules: - Paths_domaindriven_core - hs-source-dirs: - src +common default_opts + default-language: Haskell2010 default-extensions: ConstraintKinds DataKinds @@ -72,7 +57,36 @@ library TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -Wno-missing-import-lists + ghc-options: + -Wall + -Werror + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wpartial-fields + -Wredundant-constraints + -Wincomplete-record-updates + -Wincomplete-patterns + -Wunused-packages + -Wno-missing-import-lists + -threaded + -rtsopts + -with-rtsopts=-N + -Wall + +library + import: default_opts + exposed-modules: + Data.ShapeCoerce + DomainDriven.Persistance.Class + DomainDriven.Persistance.ForgetfulInMemory + DomainDriven.Persistance.Postgres + DomainDriven.Persistance.Postgres.Internal + DomainDriven.Persistance.Postgres.Migration + DomainDriven.Persistance.Postgres.Types + hs-source-dirs: + src build-depends: aeson , base @@ -96,48 +110,13 @@ library default-language: Haskell2010 test-suite domaindriven-core-test + import: default_opts type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: DomainDriven.Persistance.PostgresSpec - Paths_domaindriven_core hs-source-dirs: test - default-extensions: - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveFunctor - DeriveGeneric - DeriveTraversable - DerivingStrategies - DuplicateRecordFields - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NoImplicitPrelude - OverloadedLabels - AllowAmbiguousTypes - OverloadedStrings - PolyKinds - RankNTypes - ScopedTypeVariables - StandaloneDeriving - StrictData - TupleSections - TypeApplications - TypeFamilyDependencies - TypeOperators - TypeSynonymInstances - ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -Wno-missing-import-lists -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: aeson , base @@ -151,4 +130,3 @@ test-suite domaindriven-core-test , unliftio , unliftio-pool , uuid - default-language: Haskell2010 diff --git a/domaindriven-core/package.yaml b/domaindriven-core/package.yaml deleted file mode 100644 index 5462592..0000000 --- a/domaindriven-core/package.yaml +++ /dev/null @@ -1,116 +0,0 @@ -name: domaindriven-core -version: 0.5.0 -github: "tommyengstrom/domaindriven" -license: BSD3 -author: "Tommy Engström" -maintainer: "tommy@tommyengstrom.com" -copyright: "2022 Tommy Engström" - -extra-source-files: -- README.md -- ChangeLog.md - -# Metadata used when publishing your package -synopsis: Batteries included event sourcing and CQRS -category: Web - -# To avoid duplicated efforts in documentation and dealing with the -# complications of embedding Haddock markup inside cabal files, it is -# common to point users to the README.md file. -description: Please see the README on GitHub at - -dependencies: -- aeson -- base - - -default-extensions: -- ConstraintKinds -- DataKinds -- DeriveAnyClass -- DeriveFunctor -- DeriveGeneric -- DeriveTraversable -- DerivingStrategies -- DuplicateRecordFields -- FlexibleContexts -- FlexibleInstances -- FunctionalDependencies -- GADTs -- GeneralizedNewtypeDeriving -- ImportQualifiedPost -- LambdaCase -- MultiParamTypeClasses -- MultiWayIf -- NamedFieldPuns -- NoImplicitPrelude -- OverloadedLabels -- AllowAmbiguousTypes -- OverloadedStrings -- PolyKinds -- RankNTypes -- ScopedTypeVariables -- StandaloneDeriving -- StrictData -- TupleSections -- TypeApplications -- TypeFamilyDependencies -- TypeOperators -- TypeSynonymInstances -- ViewPatterns - -ghc-options: -- -Wall -- -Werror -- -Wcompat -- -Widentities -- -Wincomplete-record-updates -- -Wincomplete-uni-patterns -- -Wpartial-fields -- -Wredundant-constraints -- -Wincomplete-record-updates -- -Wincomplete-patterns -- -Wunused-packages -- -Wno-missing-import-lists - -library: - source-dirs: src - dependencies: - - containers - - deepseq - - exceptions - - hashable - - mtl - - postgresql-simple - - random - - resource-pool - - generic-lens - - microlens - - streamly - - streamly-core - - text - - time - - unliftio - - unordered-containers - - uuid -tests: - domaindriven-core-test: - main: Spec.hs - source-dirs: - - test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -Wall - dependencies: - - containers - - domaindriven-core - - hspec - - text - - postgresql-simple - - streamly - - time - - unliftio - - unliftio-pool - - uuid diff --git a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal index f6941aa..b6dd94e 100644 --- a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal +++ b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal @@ -1,8 +1,4 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.38.1. --- --- see: https://github.com/sol/hpack +cabal-version: 3.12 name: domaindriven-effectful-examples version: 0.5.0 @@ -13,8 +9,8 @@ homepage: https://github.com/tommyengstrom/domaindriven#readme bug-reports: https://github.com/tommyengstrom/domaindriven/issues author: Tommy Engström maintainer: tommy@tommyengstrom.com -copyright: 2023 Tommy Engström -license: BSD3 +copyright: 2025 Tommy Engström +license: BSD-3-Clause build-type: Simple extra-source-files: README.md @@ -23,15 +19,7 @@ source-repository head type: git location: https://github.com/tommyengstrom/domaindriven -executable postgres-example - main-is: Main.hs - other-modules: - Event.V1 - Event.V2 - EventMigration - Paths_domaindriven_effectful_examples - hs-source-dirs: - postgres +common shared_opts default-extensions: BlockArguments ConstraintKinds @@ -66,7 +54,33 @@ executable postgres-example TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wno-unused-packages -Wno-partial-fields -fplugin=Effectful.Plugin -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + ghc-options: + -Wall + -Werror + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wpartial-fields + -Wredundant-constraints + -Wincomplete-patterns + -Wno-unused-packages + -Wno-partial-fields + -fplugin=Effectful.Plugin + -threaded + -rtsopts + -with-rtsopts=-N + +executable postgres-example + import: shared_opts + main-is: Main.hs + other-modules: + Event.V1 + Event.V2 + EventMigration + hs-source-dirs: + postgres build-depends: aeson , base @@ -81,49 +95,12 @@ executable postgres-example , text , uuid , warp - default-language: Haskell2010 executable simple-example + import: shared_opts main-is: Main.hs - other-modules: - Paths_domaindriven_effectful_examples hs-source-dirs: simple - default-extensions: - BlockArguments - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveFunctor - DeriveGeneric - DeriveTraversable - DerivingStrategies - DuplicateRecordFields - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NoImplicitPrelude - OverloadedLabels - OverloadedStrings - PolyKinds - RankNTypes - ScopedTypeVariables - StandaloneDeriving - StrictData - TupleSections - TypeApplications - TypeFamilyDependencies - TypeOperators - TypeSynonymInstances - ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-patterns -Wno-unused-packages -Wno-partial-fields -fplugin=Effectful.Plugin -threaded -rtsopts -with-rtsopts=-N build-depends: aeson , base @@ -135,4 +112,3 @@ executable simple-example , servant , servant-server , warp - default-language: Haskell2010 diff --git a/domaindriven-effectful-examples/package.yaml b/domaindriven-effectful-examples/package.yaml deleted file mode 100644 index e7ece96..0000000 --- a/domaindriven-effectful-examples/package.yaml +++ /dev/null @@ -1,107 +0,0 @@ -name: domaindriven-effectful-examples -version: 0.5.0 -github: "tommyengstrom/domaindriven" -license: BSD3 -author: "Tommy Engström" -maintainer: "tommy@tommyengstrom.com" -copyright: "2023 Tommy Engström" - -extra-source-files: -- README.md - -# Metadata used when publishing your package -synopsis: Examples for domaindriven-effectful -category: Web - -description: Examples demonstrating the Effectful-based domaindriven library - -dependencies: -- base -- effectful-core -- effectful-plugin - -default-extensions: -- BlockArguments -- ConstraintKinds -- DataKinds -- DeriveAnyClass -- DeriveFunctor -- DeriveGeneric -- DeriveTraversable -- DerivingStrategies -- DuplicateRecordFields -- FlexibleContexts -- FlexibleInstances -- FunctionalDependencies -- GADTs -- GeneralizedNewtypeDeriving -- ImportQualifiedPost -- LambdaCase -- MultiParamTypeClasses -- MultiWayIf -- NamedFieldPuns -- NoImplicitPrelude -- OverloadedLabels -- OverloadedStrings -- PolyKinds -- RankNTypes -- ScopedTypeVariables -- StandaloneDeriving -- StrictData -- TupleSections -- TypeApplications -- TypeFamilyDependencies -- TypeOperators -- TypeSynonymInstances -- ViewPatterns - -ghc-options: -- -Wall -- -Werror -- -Wcompat -- -Widentities -- -Wincomplete-record-updates -- -Wincomplete-uni-patterns -- -Wpartial-fields -- -Wredundant-constraints -- -Wincomplete-patterns -- -Wno-unused-packages -- -Wno-partial-fields -- -fplugin=Effectful.Plugin - -executables: - simple-example: - main: Main.hs - source-dirs: simple - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - aeson - - domaindriven-core - - domaindriven-effectful - - effectful - - servant - - servant-server - - warp - - postgres-example: - main: Main.hs - source-dirs: postgres - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - aeson - - domaindriven-core - - domaindriven-effectful - - effectful - - postgresql-simple - - servant - - servant-server - - uuid - - text - - warp - diff --git a/domaindriven-effectful/domaindriven-effectful.cabal b/domaindriven-effectful/domaindriven-effectful.cabal index e8fe5af..5482a67 100644 --- a/domaindriven-effectful/domaindriven-effectful.cabal +++ b/domaindriven-effectful/domaindriven-effectful.cabal @@ -1,9 +1,4 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.38.1. --- --- see: https://github.com/sol/hpack - +cabal-version: 3.12 name: domaindriven-effectful version: 0.5.0 synopsis: Batteries included event sourcing and CQRS @@ -14,7 +9,7 @@ bug-reports: https://github.com/tommyengstrom/domaindriven/issues author: Tommy Engström maintainer: tommy@tommyengstrom.com copyright: 2023 Tommy Engström -license: BSD3 +license: BSD-3-Clause build-type: Simple extra-source-files: README.md @@ -24,20 +19,7 @@ source-repository head type: git location: https://github.com/tommyengstrom/domaindriven -library - exposed-modules: - DomainDriven.Effectful - DomainDriven.Effectful.Aggregate - DomainDriven.Effectful.Domain - DomainDriven.Effectful.Interpreter.InMemory - DomainDriven.Effectful.Interpreter.Postgres - DomainDriven.Effectful.Projection - DomainDriven.FieldNameAsPath - Servant.Auth.Internal.ThrowAll.SOP - other-modules: - Paths_domaindriven_effectful - hs-source-dirs: - src +common shared_opts default-extensions: ConstraintKinds DataKinds @@ -72,7 +54,35 @@ library TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -Wunused-packages -Wno-missing-import-lists -fplugin=Effectful.Plugin + ghc-options: + -Wall + -Werror + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wpartial-fields + -Wredundant-constraints + -Wincomplete-record-updates + -Wincomplete-patterns + -Wunused-packages + -Wno-missing-import-lists + -fplugin=Effectful.Plugin + default-language: Haskell2010 + +library + import: shared_opts + exposed-modules: + DomainDriven.Effectful + DomainDriven.Effectful.Aggregate + DomainDriven.Effectful.Domain + DomainDriven.Effectful.Interpreter.InMemory + DomainDriven.Effectful.Interpreter.Postgres + DomainDriven.Effectful.Projection + DomainDriven.FieldNameAsPath + Servant.Auth.Internal.ThrowAll.SOP + hs-source-dirs: + src build-depends: aeson , base @@ -89,4 +99,3 @@ library , servant-openapi3 , servant-server , text - default-language: Haskell2010 diff --git a/domaindriven-effectful/package.yaml b/domaindriven-effectful/package.yaml deleted file mode 100644 index 6752e16..0000000 --- a/domaindriven-effectful/package.yaml +++ /dev/null @@ -1,93 +0,0 @@ -name: domaindriven-effectful -version: 0.5.0 -github: "tommyengstrom/domaindriven" -license: BSD3 -author: "Tommy Engström" -maintainer: "tommy@tommyengstrom.com" -copyright: "2023 Tommy Engström" - -extra-source-files: -- README.md -- ChangeLog.md - -# Metadata used when publishing your package -synopsis: Batteries included event sourcing and CQRS -category: Web - -# To avoid duplicated efforts in documentation and dealing with the -# complications of embedding Haddock markup inside cabal files, it is -# common to point users to the README.md file. -description: Please see the README on GitHub at - -dependencies: -- base -- effectful-core -- effectful-plugin -- effectful-th -- domaindriven-core -- aeson -- servant-server -- servant-client-core -- servant-openapi3 -- openapi3 -- servant-auth-server -- generics-sop -- text -- bytestring - - - -default-extensions: -- ConstraintKinds -- DataKinds -- DeriveAnyClass -- DeriveFunctor -- DeriveGeneric -- DeriveTraversable -- DerivingStrategies -- DuplicateRecordFields -- FlexibleContexts -- FlexibleInstances -- FunctionalDependencies -- GADTs -- GeneralizedNewtypeDeriving -- ImportQualifiedPost -- LambdaCase -- MultiParamTypeClasses -- MultiWayIf -- NamedFieldPuns -- NoImplicitPrelude -- OverloadedLabels -- AllowAmbiguousTypes -- OverloadedStrings -- PolyKinds -- RankNTypes -- ScopedTypeVariables -- StandaloneDeriving -- StrictData -- TupleSections -- TypeApplications -- TypeFamilyDependencies -- TypeOperators -- TypeSynonymInstances -- ViewPatterns - -ghc-options: -- -Wall -- -Werror -- -Wcompat -- -Widentities -- -Wincomplete-record-updates -- -Wincomplete-uni-patterns -- -Wpartial-fields -- -Wredundant-constraints -- -Wincomplete-record-updates -- -Wincomplete-patterns -- -Wunused-packages -- -Wno-missing-import-lists -- -fplugin=Effectful.Plugin - -library: - source-dirs: src - dependencies: - - hashable diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index d72fae3..0000000 --- a/stack.yaml +++ /dev/null @@ -1,21 +0,0 @@ -resolver: lts-24.12 -packages: -- domaindriven-core -- domaindriven-effectful -- domaindriven-effectful-examples - -extra-deps: - -ghc-options: - "$locals": -fwrite-ide-info - '$everything': -haddock - -hiedir=.hie - -allow-newer: true -allow-newer-deps: - - openapi3 - - servant-auth-server - - servant-openapi3 - - insert-ordered-containers - -system-ghc: true From bcaa05180d11672bdf0c19b9c0a212ecb90da79e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Fri, 26 Sep 2025 14:02:19 +0200 Subject: [PATCH 32/50] spec for how to support postgres state --- .gitignore | 1 + specs/effectful.md | 18 ----- specs/generalized-read-model.md | 133 ++++++++++++++++++++++++++++++++ 3 files changed, 134 insertions(+), 18 deletions(-) delete mode 100644 specs/effectful.md create mode 100644 specs/generalized-read-model.md diff --git a/.gitignore b/.gitignore index eba1327..9a05b39 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,4 @@ hie.yaml dist-newstyle/ .vscode .repro +ai_docs diff --git a/specs/effectful.md b/specs/effectful.md deleted file mode 100644 index 35398e6..0000000 --- a/specs/effectful.md +++ /dev/null @@ -1,18 +0,0 @@ -We're working on prototyping a rewrite of `domaindriven` to use `Effectful`. - -## The idea - -domaindriven is currently implementing commands using custom servant combinators, `CmdI`, `CbCmdI`, `QueryI`, etc. I want to stop doing that and just use the normal servant endpoint combinators, `Post`, `Query`. This seems super obvious right now, but the history of the library put us in this spot. - -The current prototype use 3 parameters to the Effects. I don't like it, but I'm not sure how to do it without the parameters. I guess it can be simplified using funtional dependencies, `model -> event, model -> index`. - - - -## Work so far - -The initial effects are in: - -- domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs -- domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs - - diff --git a/specs/generalized-read-model.md b/specs/generalized-read-model.md new file mode 100644 index 0000000..8134334 --- /dev/null +++ b/specs/generalized-read-model.md @@ -0,0 +1,133 @@ +# Generalized `ReadModel` + +This iteration incorporates two refinements: + +1. No defaults inside the class. Defining a `ReadModel` is rare and explicit implementations keep behaviour obvious. +2. The `Model p` associated type is removed. Backends now commit only to their runtime `ResolvableModel` and query surface. + +## Supporting types + +```haskell +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +newtype StateQuery state r = StateQuery + { runStateQuery :: state -> r + } + +identityQuery :: StateQuery s s +identityQuery = StateQuery id + +data BeamQuery be db r where + BeamQuery :: (forall m. MonadBeam be m => db -> m r) -> BeamQuery be db r +``` + +The helper newtypes are optional; each backend chooses its own `Query p` type alias. + +## Proposed class + +```haskell +class ReadModel p where + type Event p :: Type -- The event type + type Index p :: Type -- Index. can be unit if not applicable. + type ResolvableModel p :: Type -- Could be the model itself, or some way of fetching it in `RunnerMonad p` + type RunnerMonad p :: Type -> Type -- The Monad where `applyEvent` and `queryModel` runs. + type Query p :: Type -> Type -- The types of queries that can be run. Identity for in memory models. + + applyEvent + :: p + -> Index p + -> Stored (Event p) + -> ResolvableModel p + -> RunnerMonad p (ResolvableModel p) + + queryModel + :: p -> Index p -> Query p r -> RunnerMonad p r + + getEventList :: p -> Index p -> IO [Stored (Event p)] + getEventStream :: HasCallStack => p -> Index p -> Stream IO (Stored (Event p)) +``` + +Every backend must explicitly choose its `RunnerMonad`, `ResolvableModel`, and `Query` carrier. There are no defaults. + +## In-memory instance + +```haskell +instance Hashable index => ReadModel (ForgetfulInMemory model index event) where + type Event (ForgetfulInMemory model index event) = event + type Index (ForgetfulInMemory model index event) = index + type ResolvableModel (ForgetfulInMemory model index event) = model + type RunnerMonad (ForgetfulInMemory model index event) = IO + type Query (ForgetfulInMemory model index event) = StateQuery model + + -- transactionalUpdate in the backend reads the current state from stateRef + -- and supplies it here as `model`. + applyEvent ff _ stored model = + pure (apply ff model stored) + + queryModel ff idx (StateQuery k) = do + state <- HM.lookupDefault (seed ff) idx <$> readIORef (stateRef ff) + pure (k state) + + getEventList ff idx = + HM.lookupDefault [] idx <$> readIORef (events ff) + + getEventStream ff idx = + Stream.bracketIO + (HM.lookupDefault [] idx <$> readIORef (events ff)) + (const (pure ())) + Stream.fromList +``` + +`StateQuery` lets callers recover the old behaviour (`identityQuery` yields the whole model) or project fields without additional boilerplate. + +## Beam/Postgres instance + +```haskell +data BeamReadModel = BeamReadModel + { pool :: Pool Connection + , db :: DatabaseSettings Postgres UserDb + } + +instance HasEventProjection UserEvent => ReadModel BeamReadModel where + type Event BeamReadModel = UserEvent + type Index BeamReadModel = UUID + type ResolvableModel BeamReadModel = BeamHandle Postgres Connection UserDb + type RunnerMonad BeamReadModel = BeamTx Postgres Connection + type Query BeamReadModel = BeamQuery Postgres UserDb + + applyEvent _ userId stored handle = + runBeamUpdate handle (mkEventProjectionQuery userId stored) + + queryModel BeamReadModel{pool, db} _ (BeamQuery q) = + withResource pool $ \conn -> runBeamPostgres conn (q db) + + getEventList = ... + getEventStream = ... +``` + +No materialised Haskell model is created unless a query requests it. Users express read patterns by constructing `BeamQuery` values: + +```haskell +latestBalance :: UUID -> BeamQuery Postgres UserDb (Maybe Balance) +latestBalance accountId = BeamQuery $ \db -> + runSelectReturningOne $ select $ do + row <- all_ (dbAccountBalance db) + guard_ (row.accountId ==. val_ accountId) + pure row.balance +``` + +## Pros + +* Backends are explicit about every capability (`RunnerMonad`, `ResolvableModel`, `Query`), making behaviour easy to audit. +* Pure backends still feel lightweight—`StateQuery` gives them the same ergonomics as before. +* Persistent backends expose typed query interfaces instead of serialising huge projections. +* The core library no longer needs to know anything about backend-specific model types. + +## Cons + +* Implementations must fill in all hooks; no defaults means more code per backend, though the count of backends is small. +* Callers must evaluate the chosen `RunnerMonad` (`Either`, `BeamTx`, etc.), which may need shims at call sites. +* Additional associated types surface in type errors. +* Each backend has to design a query language (`StateQuery`, `BeamQuery`) and maintain it as part of its API. From 8f481a06ba0447f4322e383716c596c91769e07f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Wed, 1 Oct 2025 11:52:07 +0200 Subject: [PATCH 33/50] include readme --- domaindriven-effectful/README.md | 0 domaindriven-effectful/domaindriven-effectful.cabal | 1 - 2 files changed, 1 deletion(-) create mode 100644 domaindriven-effectful/README.md diff --git a/domaindriven-effectful/README.md b/domaindriven-effectful/README.md new file mode 100644 index 0000000..e69de29 diff --git a/domaindriven-effectful/domaindriven-effectful.cabal b/domaindriven-effectful/domaindriven-effectful.cabal index 5482a67..979491e 100644 --- a/domaindriven-effectful/domaindriven-effectful.cabal +++ b/domaindriven-effectful/domaindriven-effectful.cabal @@ -13,7 +13,6 @@ license: BSD-3-Clause build-type: Simple extra-source-files: README.md - ChangeLog.md source-repository head type: git From 1d8073849b6c96a95293d34379e53b520ff18b36 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Thu, 9 Oct 2025 09:17:58 +0200 Subject: [PATCH 34/50] transactions get the current model as input --- .../src/DomainDriven/Persistance/Class.hs | 10 ++++----- .../Persistance/ForgetfulInMemory.hs | 2 +- .../Persistance/Postgres/Internal.hs | 4 ++-- .../DomainDriven/Persistance/PostgresSpec.hs | 21 +++++++++---------- .../postgres/Main.hs | 5 ++--- .../simple/Main.hs | 5 ++--- .../src/DomainDriven/Effectful/Aggregate.hs | 13 ++++++------ .../Effectful/Interpreter/InMemory.hs | 2 +- .../Effectful/Interpreter/Postgres.hs | 2 +- 9 files changed, 30 insertions(+), 34 deletions(-) diff --git a/domaindriven-core/src/DomainDriven/Persistance/Class.hs b/domaindriven-core/src/DomainDriven/Persistance/Class.hs index 04dc848..575149c 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Class.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Class.hs @@ -57,13 +57,11 @@ class ReadModel p => WriteModel p where . MonadUnliftIO m => p -> Index p - -> m (Model p -> a, [Event p]) + -> (Model p -> m (Model p -> a, [Event p])) -> m ( Model p - , -- \^ Updated model - [Stored (Event p)] - , -- \^ Stored events - (Model p -> a) + , [Stored (Event p)] + , (Model p -> a) ) -- ^ How to create the return value from updated model @@ -73,7 +71,7 @@ runCmd . (WriteModel p, MonadUnliftIO m) => p -> Index p - -> m (Model p -> a, [Event p]) + -> (Model p -> m (Model p -> a, [Event p])) -> m a runCmd p index cmd = withFrozenCallStack $ do (model, events, returnFun) <- transactionalUpdate p index cmd diff --git a/domaindriven-core/src/DomainDriven/Persistance/ForgetfulInMemory.hs b/domaindriven-core/src/DomainDriven/Persistance/ForgetfulInMemory.hs index f2b3c8a..b00a10a 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/ForgetfulInMemory.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/ForgetfulInMemory.hs @@ -59,8 +59,8 @@ instance Hashable index => WriteModel (ForgetfulInMemory model index event) wher postUpdateHook p index model events = liftIO $ updateHook p index model events transactionalUpdate ff index evalCmd = bracket_ (waitQSem $ lock ff) (signalQSem $ lock ff) $ do - (returnFun, evs) <- evalCmd model <- HM.lookupDefault (seed ff) index <$> readIORef (stateRef ff) + (returnFun, evs) <- evalCmd model storedEvs <- traverse toStored evs let newModel = foldl' (apply ff) model storedEvs modifyIORef (events ff) $ diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs index 350cd62..8b840ec 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs @@ -634,8 +634,8 @@ instance (IsPgIndex i, ToJSON e, FromJSON e) => WriteModel (PostgresEvent i m e) transactionalUpdate pg index cmd = withRunInIO $ \runInIO -> withIOTrans pg $ \pgt -> withExclusiveLock pgt index $ do - -- m <- getModel' pgt index - (returnFun, evs) <- runInIO cmd + m <- getModel' pgt index + (returnFun, evs) <- runInIO $ cmd m NumberedModel m' _ <- getCurrentState pg index storedEvs <- traverse toStored evs newNumberedModel <- diff --git a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs index 910a486..2a9a885 100644 --- a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs +++ b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs @@ -74,7 +74,7 @@ spec = do postHook p index m evs = do atomically $ modifyTVar processedEvents (<> Set.fromList (fmap storedUUID evs)) - when (m < 0) (void $ runCmd p index $ pure (id, [Reset])) + when (m < 0) (void $ runCmd p index $ \_ -> pure (id, [Reset])) in around (setupPersistance postHook) (postHookSpec processedEvents) around (setupPersistance noHook) migrationConcurrencySpec @@ -222,9 +222,8 @@ indexedSpec = describe "Indexed models" $ do m2 `shouldBe` 3 it "Updates to different indices can be done in parallel" $ \(p, _pool) -> do - -- This may fail in GHCI. Run it with stack test. - let testCmd :: Int -> IO (TestModel -> TestModel, [TestEvent]) - testCmd i = do + let testCmd :: Int -> TestModel -> IO (TestModel -> TestModel, [TestEvent]) + testCmd i _ = do threadDelay 100000 -- 0.1s delay pure (id, replicate i AddOne) t0 <- getCurrentTime @@ -241,8 +240,8 @@ indexedSpec = describe "Indexed models" $ do diffUTCTime t1 t0 `shouldSatisfy` (< 1.9) it "Updates to same index are done sequentially" $ \(p, _pool) -> do - let testCmd :: IO (TestModel -> TestModel, [TestEvent]) - testCmd = do + let testCmd :: TestModel -> IO (TestModel -> TestModel, [TestEvent]) + testCmd _ = do threadDelay 100000 -- 0.1s delay pure (id, [AddOne, AddOne]) t0 <- getCurrentTime @@ -310,7 +309,7 @@ postHookSpec processedEvents = describe "updateHook" $ do events `shouldBe` Set.empty it "Post update hook is fired after events are written" $ \(p, _) -> do - i <- runCmd p NoIndex $ do + i <- runCmd p NoIndex $ \_ -> do pure (id, [AddOne, AddOne, SubtractOne]) i `shouldBe` 1 threadDelay 100000 -- Ensure the hook has time to run @@ -319,7 +318,7 @@ postHookSpec processedEvents = describe "updateHook" $ do it "Hook that resets on negative works" $ \(p, _) -> do -- the hook will check if the model is negative and reset it if so - m <- runCmd p NoIndex $ do + m <- runCmd p NoIndex $ \_ -> do pure (id, [SubtractOne, SubtractOne, SubtractOne]) m `shouldBe` (-3) threadDelay 100000 -- Ensure the hook has time to run @@ -399,8 +398,8 @@ migrationConcurrencySpec = describe "Event table is locked during migration" $ d -> EventMigration -> IO () migrationTest m0 pool mig = do - let cmd :: IO (Int -> Int, [TestEvent]) - cmd = pure (id, [AddOne]) + let cmd :: Int -> IO (Int -> Int, [TestEvent]) + cmd _ = pure (id, [AddOne]) i <- replicateM 5 (runCmd m0 NoIndex cmd) length i `shouldBe` 5 @@ -447,7 +446,7 @@ loggingSpec :: SpecWith (PostgresEvent NoIndex TestModel TestEvent, Pool Connect loggingSpec = describe "Callstacks" $ do it "Callstack for runCmd reference this file" $ \(p', _) -> do (logVar, p) <- withStmLogger p' - _ <- runCmd p NoIndex $ pure (id, [AddOne]) + _ <- runCmd p NoIndex $ \_ -> pure (id, [AddOne]) referencesThisFile =<< readTVarIO logVar it "Callstack for getModel reference this file" $ \(p', _) -> do (logVar, p) <- withStmLogger p' diff --git a/domaindriven-effectful-examples/postgres/Main.hs b/domaindriven-effectful-examples/postgres/Main.hs index 9dceb41..f03f5a2 100644 --- a/domaindriven-effectful-examples/postgres/Main.hs +++ b/domaindriven-effectful-examples/postgres/Main.hs @@ -63,10 +63,9 @@ counterServer counterServer = CounterAPI { get = getModel - , increase = runTransaction do + , increase = runTransaction \_ -> do pure (id, [Increase]) - , decrease = runTransaction do - m <- getModel + , decrease = runTransaction \m -> do when (m <= 0) (throwError err422{errBody = "Counter cannot go below zero"}) diff --git a/domaindriven-effectful-examples/simple/Main.hs b/domaindriven-effectful-examples/simple/Main.hs index 8c5122e..380f5f4 100644 --- a/domaindriven-effectful-examples/simple/Main.hs +++ b/domaindriven-effectful-examples/simple/Main.hs @@ -68,10 +68,9 @@ counterServer = { get = do CounterModel {counter} <- getModel pure counter - , increase = runTransaction do + , increase = runTransaction \_ -> do pure (\a -> a.counter , [CounterIncreased]) - , decrease = runTransaction do - m <- getModel + , decrease = runTransaction \m -> do when (m.counter <= 0) (throwError err422{errBody = "Counter cannot go below zero"}) diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs index cff886a..36975f0 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs @@ -14,11 +14,12 @@ import Effectful.TH data Aggregate (domain :: Type) :: Effect where RunTransactionI :: DomainIndex domain - -> ( Eff - es - ( DomainModel domain -> a - , [DomainEvent domain] - ) + -> ( DomainModel domain + -> Eff + es + ( DomainModel domain -> a + , [DomainEvent domain] + ) ) -> Aggregate domain (Eff es) a @@ -30,7 +31,7 @@ runTransaction :: forall domain es a . Aggregate domain :> es => DomainIndex domain ~ NoIndex - => ( Eff + => ( DomainModel domain -> Eff es ( DomainModel domain -> a , [DomainEvent domain] diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs index 4cfc1ad..ebb7aff 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs @@ -49,5 +49,5 @@ runAggregateInMemory backend = interpret $ \env -> \case localSeqUnlift env $ \unlift -> do (model', _, returnFun) <- P.transactionalUpdate backend idx $ - unlift cmd + unlift . cmd pure $ returnFun model' diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs index 221da70..e464aed 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs @@ -50,4 +50,4 @@ runAggregatePostgres runAggregatePostgres backend = interpret $ \env -> \case RunTransactionI idx cmd -> do localSeqUnlift env $ \unlift -> - P.runCmd backend idx $ unlift cmd + P.runCmd backend idx $ unlift . cmd From 71997ceed652750fcb8f95dfff7ee49ea7a5c85d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Tue, 4 Nov 2025 11:31:48 +0100 Subject: [PATCH 35/50] run-ghcid --- run-ghcid.sh | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100755 run-ghcid.sh diff --git a/run-ghcid.sh b/run-ghcid.sh new file mode 100755 index 0000000..8ed3397 --- /dev/null +++ b/run-ghcid.sh @@ -0,0 +1,29 @@ +#!/usr/bin/env bash + +# Exit on error +set -x +set -e + +# Configuration +LOG_FILE="ghcid.log" + +echo "Starting ghciwatch" +echo "Logging to: $LOG_FILE" +echo "----------------------------------------" + +# Run ghciwatch with: +# - hpack before each startup/restart to regenerate .cabal files +# - cabal repl with the specific test-dev component +# - output redirected to log file +# +# +components=$(gen-hie |grep component|grep '".*"' -o|sed "s:\"::g" | xargs echo) + +echo cabal v2-repl --enable-multi-repl $components + +ghcid \ + --command "cabal v2-repl --enable-multi-repl $components" \ + --restart "cabal.project" \ + --restart "streaker.cabal" \ + --restart "chatcompletion-effectful.cabal" \ + -o $LOG_FILE From 24e974b20301d78d6b46199c5b2254bff182fe9e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Thu, 19 Feb 2026 08:41:29 +0100 Subject: [PATCH 36/50] add flake --- cabal.project | 2 +- flake.nix | 41 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 42 insertions(+), 1 deletion(-) create mode 100644 flake.nix diff --git a/cabal.project b/cabal.project index c57c0d0..9d89ce4 100644 --- a/cabal.project +++ b/cabal.project @@ -4,6 +4,6 @@ packages: domaindriven-effectful-examples/ -- Use Stackage LTS 24.2 as the main package source -import: https://www.stackage.org/lts-24.12/cabal.config +import: https://www.stackage.org/lts-24.31/cabal.config with-compiler: ghc-9.10.3 diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..1a292a5 --- /dev/null +++ b/flake.nix @@ -0,0 +1,41 @@ +{ + description = "domaindriven dev shell"; + + inputs = { + nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable"; + flake-utils.url = "github:numtide/flake-utils"; + }; + + outputs = { self, nixpkgs, flake-utils }: + flake-utils.lib.eachDefaultSystem (system: + let + pkgs = nixpkgs.legacyPackages.${system}; + ghc = pkgs.haskell.compiler.ghc9103; + in + { + devShells.default = pkgs.mkShell.override { stdenv = pkgs.stdenvNoCC; } { + nativeBuildInputs = [ + pkgs.pkg-config + ]; + + buildInputs = [ + pkgs.fish + ghc + pkgs.cabal-install + pkgs.haskell.packages.ghc9103.haskell-language-server + pkgs.zlib.dev + pkgs.gmp.dev + pkgs.xz.dev + pkgs.libpq + ]; + + SHELL = "${pkgs.fish}/bin/fish"; + + shellHook = '' + export PKG_CONFIG_PATH="${pkgs.xz.dev}/lib/pkgconfig:${pkgs.zlib.dev}/lib/pkgconfig:$PKG_CONFIG_PATH" + export LIBRARY_PATH="${pkgs.xz.out}/lib:${pkgs.zlib.out}/lib:${pkgs.gmp.out}/lib:${pkgs.libpq.out}/lib:$LIBRARY_PATH" + export LD_LIBRARY_PATH="${pkgs.xz.out}/lib:${pkgs.zlib.out}/lib:${pkgs.gmp.out}/lib:${pkgs.libpq.out}/lib:$LD_LIBRARY_PATH" + ''; + }; + }); +} From 567fa2f2fc4af80374523853da013977a07c99d3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Thu, 19 Feb 2026 11:45:04 +0100 Subject: [PATCH 37/50] log hook failures --- .../src/DomainDriven/Persistance/Class.hs | 4 +- flake.lock | 61 +++++++++++++++++++ flake.nix | 1 + 3 files changed, 65 insertions(+), 1 deletion(-) create mode 100644 flake.lock diff --git a/domaindriven-core/src/DomainDriven/Persistance/Class.hs b/domaindriven-core/src/DomainDriven/Persistance/Class.hs index 575149c..50b5d89 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Class.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Class.hs @@ -75,7 +75,9 @@ runCmd -> m a runCmd p index cmd = withFrozenCallStack $ do (model, events, returnFun) <- transactionalUpdate p index cmd - _ <- async $ postUpdateHook p index model events + _ <- async $ + postUpdateHook p index model events `catchAny` \e -> + liftIO $ putStrLn $ "[DomainDriven] postUpdateHook failed: " <> displayException e pure $ returnFun model -- | Wrapper for stored data diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..3c3a5a8 --- /dev/null +++ b/flake.lock @@ -0,0 +1,61 @@ +{ + "nodes": { + "flake-utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1731533236, + "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1771369470, + "narHash": "sha256-0NBlEBKkN3lufyvFegY4TYv5mCNHbi5OmBDrzihbBMQ=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "0182a361324364ae3f436a63005877674cf45efb", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixos-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-utils": "flake-utils", + "nixpkgs": "nixpkgs" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix index 1a292a5..c2ae8bd 100644 --- a/flake.nix +++ b/flake.nix @@ -23,6 +23,7 @@ ghc pkgs.cabal-install pkgs.haskell.packages.ghc9103.haskell-language-server + pkgs.haskell.packages.ghc9103.hspec-discover pkgs.zlib.dev pkgs.gmp.dev pkgs.xz.dev From 4e25eedc42a1f899c05bc122fd6efbe4c235ccc5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Thu, 19 Feb 2026 13:27:15 +0100 Subject: [PATCH 38/50] improve sql generation --- .claude/settings.local.json | 5 +- domaindriven-core/domaindriven-core.cabal | 30 ++++---- .../Persistance/Postgres/Internal.hs | 70 +++++++++++-------- .../Persistance/Postgres/Migration.hs | 9 ++- .../Persistance/Postgres/Types.hs | 8 +++ .../Persistance/Postgres/TypesSpec.hs | 31 ++++++++ 6 files changed, 100 insertions(+), 53 deletions(-) create mode 100644 domaindriven-core/test/DomainDriven/Persistance/Postgres/TypesSpec.hs diff --git a/.claude/settings.local.json b/.claude/settings.local.json index 9e29f3e..742c5d0 100644 --- a/.claude/settings.local.json +++ b/.claude/settings.local.json @@ -10,8 +10,9 @@ "WebFetch(domain:hackage.haskell.org)", "WebFetch(domain:hackage-content.haskell.org)", "WebFetch(domain:github.com)", - "Bash(stack build:*)" + "Bash(stack build:*)", + "WebFetch(domain:www.stackage.org)" ], "deny": [] } -} \ No newline at end of file +} diff --git a/domaindriven-core/domaindriven-core.cabal b/domaindriven-core/domaindriven-core.cabal index a6ef9c0..ab72e31 100644 --- a/domaindriven-core/domaindriven-core.cabal +++ b/domaindriven-core/domaindriven-core.cabal @@ -58,22 +58,17 @@ common default_opts TypeSynonymInstances ViewPatterns ghc-options: - -Wall - -Werror - -Wcompat - -Widentities - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wpartial-fields - -Wredundant-constraints - -Wincomplete-record-updates - -Wincomplete-patterns - -Wunused-packages - -Wno-missing-import-lists - -threaded - -rtsopts - -with-rtsopts=-N -Wall + -Werror + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wpartial-fields + -Wredundant-constraints + -Wincomplete-patterns + -Wunused-packages + -Wno-missing-import-lists library import: default_opts @@ -113,8 +108,13 @@ test-suite domaindriven-core-test import: default_opts type: exitcode-stdio-1.0 main-is: Spec.hs + ghc-options: + -threaded + -rtsopts + -with-rtsopts=-N other-modules: DomainDriven.Persistance.PostgresSpec + DomainDriven.Persistance.Postgres.TypesSpec hs-source-dirs: test build-depends: diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs index 8b840ec..bd1a988 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs @@ -5,6 +5,7 @@ import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class import Data.Aeson +import Data.Char (isAsciiLower, isAsciiUpper, isDigit) import Data.Foldable import Data.Generics.Labels () import Data.Generics.Product @@ -109,12 +110,20 @@ instance (IsPgIndex i, FromJSON e) => ReadModel (PostgresEvent i m e) where getEventStream pg = withStreamReadTransaction pg . flip getEventStream' getEventTableName :: EventTable -> EventTableName -getEventTableName = go 0 +getEventTableName = validate . go 0 where go :: Int -> EventTable -> String go i = \case MigrateUsing _ u -> go (i + 1) u InitialVersion n -> n <> "_v" <> show (i + 1) + validate name + | all isValidChar name && not (null name) = name + | otherwise = + error $ + "[DomainDriven] Invalid event table name: " + <> show name + <> ". Names must be non-empty and contain only [a-zA-Z0-9_]." + isValidChar c = isAsciiLower c || isAsciiUpper c || isDigit c || c == '_' -- | Create the table required for storing state and events, if they do not yet exist. createEventTable :: PostgresEventTrans index model event -> IO () @@ -128,9 +137,9 @@ createEventTable' :: Connection -> EventTableName -> IO Int64 createEventTable' conn eventTable = do _ <- execute_ conn $ - "create table if not exists \"" - <> fromString eventTable - <> "\" \ + "create table if not exists " + <> quoteIdent eventTable + <> " \ \( id uuid primary key\ \, index varchar not null\ \, event_number bigint not null generated always as identity\ @@ -138,18 +147,18 @@ createEventTable' conn eventTable = do \, event jsonb not null\ \);" execute_ conn $ - "create index on \"" - <> fromString eventTable - <> "\" (index, event_number);" + "create index on " + <> quoteIdent eventTable + <> " (index, event_number);" retireTable :: Connection -> EventTableName -> IO () retireTable conn tableName = do createRetireFunction conn void $ execute_ conn $ - "create trigger retired before insert on \"" - <> fromString tableName - <> "\" execute procedure retired_table()" + "create trigger retired before insert on " + <> quoteIdent tableName + <> " execute procedure retired_table()" createRetireFunction :: Connection -> IO () createRetireFunction conn = @@ -276,9 +285,9 @@ queryEvents conn eventTable index = do where q :: PG.Query q = - "select id, event_number,timestamp,event from \"" - <> fromString eventTable - <> "\" where index = " + "select id, event_number,timestamp,event from " + <> quoteIdent eventTable + <> " where index = " <> toQuery index <> " order by event_number" @@ -292,9 +301,9 @@ queryEventsAfter conn eventTable (EventNumber lastEvent) = traverse fromEventRow =<< query_ conn - ( "select id, event_number,timestamp,event from \"" - <> fromString eventTable - <> "\" where event_number > " + ( "select id, event_number,timestamp,event from " + <> quoteIdent eventTable + <> " where event_number > " <> fromString (show lastEvent) <> " order by event_number" ) @@ -310,9 +319,9 @@ mkEventsAfterQuery -> EventQuery mkEventsAfterQuery eventTable index (EventNumber lastEvent) = EventQuery $ - "select id, event_number,timestamp,event from \"" - <> fromString eventTable - <> "\" where index = " + "select id, event_number,timestamp,event from " + <> quoteIdent eventTable + <> " where index = " <> toQuery index <> " and event_number > " <> fromString (show lastEvent) @@ -321,9 +330,9 @@ mkEventsAfterQuery eventTable index (EventNumber lastEvent) = mkEventQuery :: IsPgIndex index => EventTableName -> index -> EventQuery mkEventQuery eventTable index = EventQuery $ - "select id, event_number,timestamp,event from \"" - <> fromString eventTable - <> "\" where index = " + "select id, event_number,timestamp,event from " + <> quoteIdent eventTable + <> " where index = " <> toQuery index <> " order by event_number" @@ -338,9 +347,9 @@ queryHasEventsAfter conn eventTable (EventNumber lastEvent) = where q :: PG.Query q = - "select count(*) > 0 from \"" - <> fromString eventTable - <> "\" where event_number > " + "select count(*) > 0 from " + <> quoteIdent eventTable + <> " where event_number > " <> fromString (show lastEvent) -- writeEvents @@ -381,9 +390,9 @@ writeEvents conn eventTable index storedEvents = do _ <- executeMany conn - ( "insert into \"" - <> fromString eventTable - <> "\" (id, index, timestamp, event) \ + ( "insert into " + <> quoteIdent eventTable + <> " (id, index, timestamp, event) \ \values (?, ?, ?, ?)" ) ( fmap @@ -399,9 +408,8 @@ writeEvents conn eventTable index storedEvents = do foldl' max 0 . fmap fromOnly <$> query_ conn - ( "select coalesce(max(event_number),1) from \"" - <> fromString eventTable - <> "\"" + ( "select coalesce(max(event_number),1) from " + <> quoteIdent eventTable ) getEventStream' diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Migration.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Migration.hs index fda3839..c7f0fc6 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Migration.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Migration.hs @@ -6,7 +6,6 @@ import Control.Monad import Data.Aeson import Data.Foldable import Data.Int -import Data.String import Database.PostgreSQL.Simple as PG import DomainDriven.Persistance.Class import DomainDriven.Persistance.Postgres.Internal (mkEventQuery, mkEventStream) @@ -123,9 +122,9 @@ migrate1toManyWithState' chunkSize conn prevTName tName f initialState = do writeIt index events = PG.executeMany conn - ( "insert into \"" - <> fromString tName - <> "\" (id, index, timestamp, event) \ + ( "insert into " + <> quoteIdent tName + <> " (id, index, timestamp, event) \ \values (?, ?, ?, ?)" ) ( fmap @@ -142,4 +141,4 @@ fetchAllIndices fetchAllIndices conn etName = fmap (fromPgIndex . fromOnly) <$> PG.query_ conn q where q :: PG.Query - q = "select distinct index from \"" <> fromString etName <> "\" order by index;" + q = "select distinct index from " <> quoteIdent etName <> " order by index;" diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Types.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Types.hs index a7baa56..e3ffb76 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Types.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Types.hs @@ -18,6 +18,14 @@ import DomainDriven.Persistance.Class import GHC.Generics (Generic) import Prelude +-- | Quote a PostgreSQL identifier (table/column name). +-- Escapes embedded double quotes by doubling them per SQL standard. +quoteIdent :: String -> PG.Query +quoteIdent name = "\"" <> fromString (concatMap escChar name) <> "\"" + where + escChar '"' = "\"\"" + escChar c = [c] + data PersistanceError = EncodingError String | ValueError String diff --git a/domaindriven-core/test/DomainDriven/Persistance/Postgres/TypesSpec.hs b/domaindriven-core/test/DomainDriven/Persistance/Postgres/TypesSpec.hs new file mode 100644 index 0000000..f9d3158 --- /dev/null +++ b/domaindriven-core/test/DomainDriven/Persistance/Postgres/TypesSpec.hs @@ -0,0 +1,31 @@ +module DomainDriven.Persistance.Postgres.TypesSpec where + +import Control.Exception (ErrorCall, evaluate) +import DomainDriven.Persistance.Postgres.Internal (getEventTableName) +import DomainDriven.Persistance.Postgres.Types (EventTable (..), quoteIdent) +import Test.Hspec +import Prelude + +spec :: Spec +spec = do + describe "quoteIdent" $ do + it "quotes a simple identifier" $ do + quoteIdent "foo" `shouldBe` "\"foo\"" + it "escapes embedded double quotes by doubling them" $ do + quoteIdent "has\"quote" `shouldBe` "\"has\"\"quote\"" + it "handles empty string" $ do + quoteIdent "" `shouldBe` "\"\"" + + describe "getEventTableName" $ do + it "computes name for InitialVersion" $ do + getEventTableName (InitialVersion "valid_name") `shouldBe` "valid_name_v1" + it "computes name for MigrateUsing" $ do + getEventTableName + (MigrateUsing (\_ _ _ -> pure ()) (InitialVersion "tbl")) + `shouldBe` "tbl_v2" + it "rejects names with unsafe characters" $ do + evaluate (getEventTableName (InitialVersion "bad;name")) + `shouldThrow` \(_ :: ErrorCall) -> True + it "rejects names with double quotes" $ do + evaluate (getEventTableName (InitialVersion "bad\"name")) + `shouldThrow` \(_ :: ErrorCall) -> True From 2240d352c43f3bfdf1e387bfc34facc08349eed9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Thu, 19 Feb 2026 13:48:08 +0100 Subject: [PATCH 39/50] remove redundant model read --- .claude/settings.local.json | 10 ++-------- .../src/DomainDriven/Persistance/Postgres/Internal.hs | 3 +-- 2 files changed, 3 insertions(+), 10 deletions(-) diff --git a/.claude/settings.local.json b/.claude/settings.local.json index 742c5d0..0dbb16d 100644 --- a/.claude/settings.local.json +++ b/.claude/settings.local.json @@ -1,17 +1,11 @@ { "permissions": { "allow": [ - "Bash(stack build)", - "Bash(stack test)", - "Bash(rg:*)", - "Bash(find:*)", - "Bash(grep:*)", - "Bash(stack test:*)", "WebFetch(domain:hackage.haskell.org)", "WebFetch(domain:hackage-content.haskell.org)", "WebFetch(domain:github.com)", - "Bash(stack build:*)", - "WebFetch(domain:www.stackage.org)" + "WebFetch(domain:www.stackage.org)", + "Bash(cabal:*)" ], "deny": [] } diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs index bd1a988..413b59e 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs @@ -644,13 +644,12 @@ instance (IsPgIndex i, ToJSON e, FromJSON e) => WriteModel (PostgresEvent i m e) withIOTrans pg $ \pgt -> withExclusiveLock pgt index $ do m <- getModel' pgt index (returnFun, evs) <- runInIO $ cmd m - NumberedModel m' _ <- getCurrentState pg index storedEvs <- traverse toStored evs newNumberedModel <- uncurry NumberedModel <$> concurrently ( Stream.fold - (Fold.foldl' (pg ^. field @"app") m') + (Fold.foldl' (pg ^. field @"app") m) (Stream.fromList storedEvs) ) ( writeEvents From fbc606e57500f0eea006428af34862702ec64659 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Fri, 20 Feb 2026 16:49:11 +0100 Subject: [PATCH 40/50] test more --- .../domaindriven-effectful.cabal | 20 +++++ .../DomainDriven/Effectful/InMemorySpec.hs | 90 +++++++++++++++++++ domaindriven-effectful/test/Spec.hs | 1 + 3 files changed, 111 insertions(+) create mode 100644 domaindriven-effectful/test/DomainDriven/Effectful/InMemorySpec.hs create mode 100644 domaindriven-effectful/test/Spec.hs diff --git a/domaindriven-effectful/domaindriven-effectful.cabal b/domaindriven-effectful/domaindriven-effectful.cabal index 979491e..90381cf 100644 --- a/domaindriven-effectful/domaindriven-effectful.cabal +++ b/domaindriven-effectful/domaindriven-effectful.cabal @@ -98,3 +98,23 @@ library , servant-openapi3 , servant-server , text + +test-suite domaindriven-effectful-test + import: shared_opts + type: exitcode-stdio-1.0 + main-is: Spec.hs + ghc-options: + -threaded + -rtsopts + -with-rtsopts=-N + other-modules: + DomainDriven.Effectful.InMemorySpec + hs-source-dirs: + test + build-depends: + base + , domaindriven-core + , domaindriven-effectful + , effectful-core + , effectful-plugin + , hspec diff --git a/domaindriven-effectful/test/DomainDriven/Effectful/InMemorySpec.hs b/domaindriven-effectful/test/DomainDriven/Effectful/InMemorySpec.hs new file mode 100644 index 0000000..c1ddcb3 --- /dev/null +++ b/domaindriven-effectful/test/DomainDriven/Effectful/InMemorySpec.hs @@ -0,0 +1,90 @@ +module DomainDriven.Effectful.InMemorySpec (spec) where + +import DomainDriven.Effectful.Aggregate +import DomainDriven.Effectful.Domain +import DomainDriven.Effectful.Interpreter.InMemory +import DomainDriven.Effectful.Projection +import DomainDriven.Persistance.Class (Indexed (..), NoIndex (..), Stored (..)) +import DomainDriven.Persistance.ForgetfulInMemory () +import Effectful +import Test.Hspec +import Prelude + +type TestModel = Int + +data TestEvent = AddOne | SubtractOne | Reset + deriving (Show, Eq) + +applyTestEvent :: TestModel -> Stored TestEvent -> TestModel +applyTestEvent m ev = case storedEvent ev of + AddOne -> m + 1 + SubtractOne -> m - 1 + Reset -> 0 + +type TestDomain = Domain TestModel TestEvent NoIndex +type IndexedTestDomain = Domain TestModel TestEvent Indexed + +runTest + :: ForgetfulInMemory TestModel NoIndex TestEvent + -> Eff '[Aggregate TestDomain, Projection TestDomain, IOE] a + -> IO a +runTest backend = + runEff + . runProjectionInMemory backend + . runAggregateInMemory backend + +runIndexedTest + :: ForgetfulInMemory TestModel Indexed TestEvent + -> Eff '[Aggregate IndexedTestDomain, Projection IndexedTestDomain, IOE] a + -> IO a +runIndexedTest backend = + runEff + . runProjectionInMemory backend + . runAggregateInMemory backend + +spec :: Spec +spec = do + describe "Aggregate interpreter" $ do + it "runTransaction persists state via getModel" $ do + backend <- createForgetful applyTestEvent (0 :: TestModel) + runTest backend $ + runTransaction @TestDomain $ \_ -> pure (const (), [AddOne]) + m <- runTest backend (getModel @TestDomain) + m `shouldBe` 1 + + it "runTransaction applies returnFun to the updated model" $ do + backend <- createForgetful applyTestEvent (0 :: TestModel) + result <- runTest backend $ + runTransaction @TestDomain $ \_ -> + pure (id, [AddOne, AddOne]) + result `shouldBe` 2 + + it "callback can use effects from the stack via localSeqUnlift" $ do + backend <- createForgetful applyTestEvent (0 :: TestModel) + result <- runTest backend $ do + runTransaction @TestDomain $ \_ -> pure (const (), [AddOne]) + runTransaction @TestDomain $ \_ -> do + m <- getModel @TestDomain + pure (const m, []) + result `shouldBe` 1 + + describe "Projection interpreter" $ do + it "getEventList returns stored events in order" $ do + backend <- createForgetful applyTestEvent (0 :: TestModel) + runTest backend $ + runTransaction @TestDomain $ \_ -> pure (const (), [AddOne, SubtractOne]) + evs <- runTest backend (getEventList @TestDomain) + map storedEvent evs `shouldBe` [AddOne, SubtractOne] + + describe "Indexed dispatch" $ do + it "runTransactionI and getModelI dispatch to separate indices" $ do + backend <- createForgetful applyTestEvent (0 :: TestModel) + runIndexedTest backend $ do + runTransactionI @IndexedTestDomain (Indexed "a") $ \_ -> + pure (const (), [AddOne]) + runTransactionI @IndexedTestDomain (Indexed "b") $ \_ -> + pure (const (), [AddOne, AddOne]) + ma <- runIndexedTest backend (getModelI @IndexedTestDomain (Indexed "a")) + mb <- runIndexedTest backend (getModelI @IndexedTestDomain (Indexed "b")) + ma `shouldBe` 1 + mb `shouldBe` 2 diff --git a/domaindriven-effectful/test/Spec.hs b/domaindriven-effectful/test/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/domaindriven-effectful/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} From 1fef4b00b23b04df295a64d813487f22fb67e519 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Tue, 24 Feb 2026 09:13:28 +0100 Subject: [PATCH 41/50] add hspec-discover dependency --- domaindriven-effectful/domaindriven-effectful.cabal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/domaindriven-effectful/domaindriven-effectful.cabal b/domaindriven-effectful/domaindriven-effectful.cabal index 90381cf..67b3a2d 100644 --- a/domaindriven-effectful/domaindriven-effectful.cabal +++ b/domaindriven-effectful/domaindriven-effectful.cabal @@ -107,6 +107,8 @@ test-suite domaindriven-effectful-test -threaded -rtsopts -with-rtsopts=-N + build-tool-depends: + hspec-discover:hspec-discover other-modules: DomainDriven.Effectful.InMemorySpec hs-source-dirs: From b4987788fda2962df02338f059315b67cf30023e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Tue, 24 Feb 2026 09:24:06 +0100 Subject: [PATCH 42/50] update CI to use nix flake dev shell with cabal Co-Authored-By: Claude Opus 4.6 --- .github/workflows/main.yaml | 60 +++++++++++++++++-------------------- 1 file changed, 27 insertions(+), 33 deletions(-) diff --git a/.github/workflows/main.yaml b/.github/workflows/main.yaml index ff1b8de..f4537e0 100644 --- a/.github/workflows/main.yaml +++ b/.github/workflows/main.yaml @@ -2,20 +2,13 @@ name: Run tests on: push: - branches: [master] - pull_request: - branches: ['*'] jobs: test: runs-on: ubuntu-latest - env: - COMPOSE_DOCKER_CLI_BUILD: 1 - DOCKER_BUILDKIT: 1 - services: - claims-db: + postgres: image: postgres env: POSTGRES_PASSWORD: postgres @@ -29,31 +22,32 @@ jobs: - 5432:5432 steps: - - uses: actions/checkout@v2 - - name: ACTIONS_ALLOW_UNSECURE_COMMANDS - id: ACTIONS_ALLOW_UNSECURE_COMMANDS - run: echo 'ACTIONS_ALLOW_UNSECURE_COMMANDS=true' >> $GITHUB_ENV - - - name: Update stack - run: stack update - - uses: actions/cache@v2 - name: Cache ~/.stack + - uses: actions/checkout@v4 + + - uses: cachix/install-nix-action@v30 with: - path: ~/.stack - key: ${{ runner.os }}-stack-${{ hashFiles('stack.yaml') }} - - name: Build dependencies - run: | - stack build --only-dependencies --fast - - - uses: actions/cache@v2 - name: Cache .stack-work + nix_path: nixpkgs=channel:nixos-unstable + + - uses: DeterminateSystems/magic-nix-cache-action@main + + - name: Cache cabal store + uses: actions/cache@v4 with: - path: .stack-work - key: ${{ runner.os }}-stack-${{ hashFiles('services/claims/package.yaml') }} - - name: Build domaindriven - run: | - stack build --fast - - name: Run tests - run: | - stack test --fast + path: ~/.cabal/store + key: ${{ runner.os }}-cabal-${{ hashFiles('cabal.project', '**/*.cabal') }} + restore-keys: | + ${{ runner.os }}-cabal- + - name: Cache dist-newstyle + uses: actions/cache@v4 + with: + path: dist-newstyle + key: ${{ runner.os }}-dist-${{ hashFiles('cabal.project', '**/*.cabal', '**/*.hs') }} + restore-keys: | + ${{ runner.os }}-dist- + + - name: Build + run: nix develop --command cabal build all + + - name: Run tests + run: nix develop --command cabal test all From a628bc085e8b7b822a24ad42d6595d716589b958 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Tue, 24 Feb 2026 11:12:08 +0100 Subject: [PATCH 43/50] add cabal update step and fix caching Co-Authored-By: Claude Opus 4.6 --- .github/workflows/main.yaml | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/.github/workflows/main.yaml b/.github/workflows/main.yaml index f4537e0..713aab2 100644 --- a/.github/workflows/main.yaml +++ b/.github/workflows/main.yaml @@ -30,21 +30,19 @@ jobs: - uses: DeterminateSystems/magic-nix-cache-action@main - - name: Cache cabal store + - name: Cache cabal uses: actions/cache@v4 with: - path: ~/.cabal/store + path: | + ~/.cabal/store + ~/.cabal/packages + dist-newstyle key: ${{ runner.os }}-cabal-${{ hashFiles('cabal.project', '**/*.cabal') }} restore-keys: | ${{ runner.os }}-cabal- - - name: Cache dist-newstyle - uses: actions/cache@v4 - with: - path: dist-newstyle - key: ${{ runner.os }}-dist-${{ hashFiles('cabal.project', '**/*.cabal', '**/*.hs') }} - restore-keys: | - ${{ runner.os }}-dist- + - name: Update package index + run: nix develop --command cabal update - name: Build run: nix develop --command cabal build all From 0976f0a08e57571e551ad29bd4997fb98f629754 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Tue, 24 Feb 2026 11:23:28 +0100 Subject: [PATCH 44/50] update documentation --- CLAUDE.md | 17 ++++++----------- domaindriven-effectful-examples/README.md | 20 ++++++-------------- 2 files changed, 12 insertions(+), 25 deletions(-) diff --git a/CLAUDE.md b/CLAUDE.md index 5dd7d85..d8588cc 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -4,11 +4,11 @@ This file provides guidance to Claude Code (claude.ai/code) when working with co ## Build Commands -- **Build all packages**: `stack build` -- **Build specific package**: `stack build domaindriven-effectful` -- **Run tests**: `stack test` -- **Run specific test**: `stack test domaindriven-effectful` -- **Clean build**: `stack clean` +- **Build all packages**: `cabal build all` +- **Build specific package**: `cabal build domaindriven-effectful` +- **Run tests**: `cabal test all` +- **Run specific test**: `cabal test domaindriven-effectful` +- **Clean build**: `cabal clean` ## Architecture Overview @@ -22,11 +22,6 @@ DomainDriven is a synchronous event sourcing and CQRS library split into multipl - `Postgres`: Production persistence with transactional guarantees - Synchronous event sourcing with locks to avoid eventual consistency issues -- **domaindriven**: Main library using GADTs and Template Haskell for API generation - - Custom Servant combinators (`Cmd`, `Query`, `CbCmd`, `CbQuery`) - - `DomainDrivenApi` wrapper for automatic route generation - - Server interpreters that connect to persistence backends - - **domaindriven-effectful**: Experimental Effectful-based implementation - Uses standard Servant combinators instead of custom ones - Two main effects: `Aggregate` (commands) and `Projection` (queries) @@ -52,7 +47,7 @@ DomainDriven is a synchronous event sourcing and CQRS library split into multipl ## Development Notes -- All packages use extensive language extensions (see package.yaml files) +- All packages use extensive language extensions (see .cabal files) - Strict warning settings (`-Wall -Werror`) - fix all warnings before committing - The Effectful prototype aims to simplify the API while maintaining type safety - Tests use `hspec` framework with in-memory backends \ No newline at end of file diff --git a/domaindriven-effectful-examples/README.md b/domaindriven-effectful-examples/README.md index 06f0566..31cf552 100644 --- a/domaindriven-effectful-examples/README.md +++ b/domaindriven-effectful-examples/README.md @@ -9,29 +9,21 @@ Basic counter application using Effectful effects with standard Servant API. Run with: ```bash -stack run simple +cabal run simple-example ``` -### Simple with Helpers -Counter application using simplified helper functions to reduce boilerplate. +### Postgres Example +Counter application with PostgreSQL persistence and event migration. Run with: ```bash -stack run simple-with-helpers -``` - -### Hierarchical -Complex example with hierarchical models and sub-model composition. - -Run with: -```bash -stack run hierarchical +cabal run postgres-example ``` ## Features Demonstrated - Using standard Servant combinators (`Get`, `Post`) instead of custom ones - Effectful effects for domain logic -- In-memory persistence backend +- In-memory and PostgreSQL persistence backends - Type-safe effect composition -- Helper functions for common patterns \ No newline at end of file +- Event versioning and migration From 184d64009c9d3a61e8beeccae7404060f137d5c1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Tue, 24 Feb 2026 11:30:02 +0100 Subject: [PATCH 45/50] Make it easier for users to change pool settings --- .../src/DomainDriven/Persistance/Postgres.hs | 2 ++ .../Persistance/Postgres/Internal.hs | 33 ++++++++++++++----- .../Persistance/Postgres/Types.hs | 7 +++- 3 files changed, 32 insertions(+), 10 deletions(-) diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres.hs index bd6f962..06476f5 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres.hs @@ -9,6 +9,8 @@ import DomainDriven.Persistance.Postgres.Internal as X , postgresWriteModelNoMigration , simplePool , simplePool' + , simplePoolWith + , simplePoolWith' ) import DomainDriven.Persistance.Postgres.Types as X ( ChunkSize diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs index 413b59e..a1096e6 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs @@ -168,19 +168,34 @@ createRetireFunction conn = \$$ begin raise exception 'Event table has been retired.'; end; $$ \ \language plpgsql;" -simplePool' :: MonadUnliftIO m => PG.ConnectInfo -> m (Pool Connection) -simplePool' connInfo = simplePool (PG.connect connInfo) - +-- | Create a connection pool with default settings (1 stripe, 5 connections, 60s idle). simplePool :: MonadUnliftIO m => IO Connection -> m (Pool Connection) -simplePool getConn = do +simplePool = simplePoolWith id + +-- | Create a connection pool, applying a modifier to the default PoolConfig. +simplePoolWith + :: MonadUnliftIO m + => (Pool.PoolConfig Connection -> Pool.PoolConfig Connection) + -> IO Connection + -> m (Pool Connection) +simplePoolWith modifyConfig getConn = do -- Using a single stripe to ensures all thread can use all connections - let poolCfg :: Pool.PoolConfig Connection - poolCfg = - Pool.setNumStripes (Just 1) $ - Pool.defaultPoolConfig (liftIO getConn) (liftIO . PG.close) 60 5 - + let poolCfg = + modifyConfig + . Pool.setNumStripes (Just 1) + $ Pool.defaultPoolConfig (liftIO getConn) (liftIO . PG.close) 60 5 liftIO $ Pool.newPool poolCfg +simplePool' :: MonadUnliftIO m => PG.ConnectInfo -> m (Pool Connection) +simplePool' = simplePoolWith' id + +simplePoolWith' + :: MonadUnliftIO m + => (Pool.PoolConfig Connection -> Pool.PoolConfig Connection) + -> PG.ConnectInfo + -> m (Pool Connection) +simplePoolWith' modifyConfig connInfo = simplePoolWith modifyConfig (PG.connect connInfo) + -- | Setup the persistance model and verify that the tables exist. postgresWriteModelNoMigration :: HasCallStack diff --git a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Types.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Types.hs index e3ffb76..bb58671 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Types.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Types.hs @@ -1,4 +1,9 @@ -module DomainDriven.Persistance.Postgres.Types where +module DomainDriven.Persistance.Postgres.Types + ( module DomainDriven.Persistance.Postgres.Types + , Pool.PoolConfig + , Pool.setNumStripes + ) +where import Control.Monad.Catch import Data.Aeson From e9a880a443d7b5a186567aa479f370de1ad87994 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Wed, 25 Feb 2026 09:14:23 +0100 Subject: [PATCH 46/50] refactor hooks --- domaindriven-core/domaindriven-core.cabal | 1 + .../src/DomainDriven/Persistance/Class.hs | 40 +++--- .../DomainDriven/Persistance/PostgresSpec.hs | 13 +- .../postgres/Main.hs | 8 +- .../simple/Main.hs | 6 +- .../domaindriven-effectful.cabal | 8 +- .../src/DomainDriven/Effectful.hs | 1 + .../src/DomainDriven/Effectful/Interpreter.hs | 50 +++++++ .../Effectful/Interpreter/InMemory.hs | 53 ------- .../Effectful/Interpreter/Postgres.hs | 53 ------- .../DomainDriven/Effectful/InMemorySpec.hs | 68 ++++++++- run-ghcid.sh | 7 +- specs/generalized-read-model.md | 133 ------------------ 13 files changed, 152 insertions(+), 289 deletions(-) create mode 100644 domaindriven-effectful/src/DomainDriven/Effectful/Interpreter.hs delete mode 100644 domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs delete mode 100644 domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs delete mode 100644 specs/generalized-read-model.md diff --git a/domaindriven-core/domaindriven-core.cabal b/domaindriven-core/domaindriven-core.cabal index ab72e31..ac50c56 100644 --- a/domaindriven-core/domaindriven-core.cabal +++ b/domaindriven-core/domaindriven-core.cabal @@ -45,6 +45,7 @@ common default_opts NoImplicitPrelude OverloadedLabels AllowAmbiguousTypes + BlockArguments OverloadedStrings PolyKinds RankNTypes diff --git a/domaindriven-core/src/DomainDriven/Persistance/Class.hs b/domaindriven-core/src/DomainDriven/Persistance/Class.hs index 50b5d89..6707596 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Class.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Class.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} - module DomainDriven.Persistance.Class where import Control.DeepSeq (NFData) @@ -17,6 +11,7 @@ import Data.UUID (UUID) import GHC.Generics (Generic) import GHC.Stack import Streamly.Data.Stream.Prelude (Stream) +import System.IO (hPutStrLn) import System.Random import UnliftIO import Prelude @@ -40,7 +35,7 @@ class ReadModel p where class ReadModel p => WriteModel p where -- | Hook to call after model has been updated. -- This allows for setting up outgoing hooks in calling out to external systems. - -- This is run in asyncly after update is processed. + -- This is run asynchronously after update is processed. postUpdateHook :: MonadIO m => p @@ -49,8 +44,6 @@ class ReadModel p => WriteModel p where -> [Stored (Event p)] -> m () - -- | Update the model in a transaction. Note that this is never used directly; - -- runCmd calls transactionalUpdate and makes sure to call postUpdateHook afterwards. transactionalUpdate :: HasCallStack => forall m a @@ -65,21 +58,6 @@ class ReadModel p => WriteModel p where ) -- ^ How to create the return value from updated model -runCmd - :: HasCallStack - => forall p m a - . (WriteModel p, MonadUnliftIO m) - => p - -> Index p - -> (Model p -> m (Model p -> a, [Event p])) - -> m a -runCmd p index cmd = withFrozenCallStack $ do - (model, events, returnFun) <- transactionalUpdate p index cmd - _ <- async $ - postUpdateHook p index model events `catchAny` \e -> - liftIO $ putStrLn $ "[DomainDriven] postUpdateHook failed: " <> displayException e - pure $ returnFun model - -- | Wrapper for stored data -- This ensures all events have a unique ID and a timestamp, without having to deal with -- that when implementing the model. @@ -101,6 +79,20 @@ data Stored a = Stored , NFData ) +runCmd + :: HasCallStack + => forall p m a + . (WriteModel p, MonadUnliftIO m) + => p + -> Index p + -> (Model p -> m (Model p -> a, [Event p])) + -> m a +runCmd p index cmd = withFrozenCallStack $ do + (model, events, returnFun) <- transactionalUpdate p index cmd + _ <- liftIO $ async $ postUpdateHook p index model events `catchAny` \e -> + hPutStrLn stderr $ "[DomainDriven] postUpdateHook failed: " <> displayException e + pure $ returnFun model + mkId :: MonadIO m => m UUID mkId = liftIO randomIO diff --git a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs index 2a9a885..b76208a 100644 --- a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs +++ b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs @@ -4,6 +4,7 @@ module DomainDriven.Persistance.PostgresSpec where import Control.Concurrent (threadDelay) +import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) import Control.Exception (SomeException) import Control.Monad import Data.Aeson (FromJSON, ToJSON, Value) @@ -65,6 +66,7 @@ spec = do queryEventsSpec migrationSpec -- make sure migrationSpec is run last! processedEvents <- runIO $ newTVarIO (Set.empty :: Set UUID) + hookDone <- runIO newChan let postHook :: PostgresEvent NoIndex TestModel TestEvent -> NoIndex @@ -75,7 +77,8 @@ spec = do atomically $ modifyTVar processedEvents (<> Set.fromList (fmap storedUUID evs)) when (m < 0) (void $ runCmd p index $ \_ -> pure (id, [Reset])) - in around (setupPersistance postHook) (postHookSpec processedEvents) + writeChan hookDone () + in around (setupPersistance postHook) (postHookSpec hookDone processedEvents) around (setupPersistance noHook) migrationConcurrencySpec around (setupPersistance noHook) loggingSpec @@ -302,8 +305,8 @@ queryEventsSpec = describe "queryEvents" $ do event_numbers `shouldSatisfy` (\n -> and $ zipWith (>) (drop 1 n) n) postHookSpec - :: TVar (Set UUID) -> SpecWith (PostgresEvent NoIndex TestModel TestEvent, Pool Connection) -postHookSpec processedEvents = describe "updateHook" $ do + :: Chan () -> TVar (Set UUID) -> SpecWith (PostgresEvent NoIndex TestModel TestEvent, Pool Connection) +postHookSpec hookDone processedEvents = describe "updateHook" $ do it "Ensure we start with empty TVar" $ \_ -> do events <- readTVarIO processedEvents events `shouldBe` Set.empty @@ -312,7 +315,7 @@ postHookSpec processedEvents = describe "updateHook" $ do i <- runCmd p NoIndex $ \_ -> do pure (id, [AddOne, AddOne, SubtractOne]) i `shouldBe` 1 - threadDelay 100000 -- Ensure the hook has time to run + readChan hookDone events <- readTVarIO processedEvents Set.size events `shouldBe` 3 @@ -321,7 +324,7 @@ postHookSpec processedEvents = describe "updateHook" $ do m <- runCmd p NoIndex $ \_ -> do pure (id, [SubtractOne, SubtractOne, SubtractOne]) m `shouldBe` (-3) - threadDelay 100000 -- Ensure the hook has time to run + readChan hookDone m' <- getModel p NoIndex m' `shouldBe` 0 diff --git a/domaindriven-effectful-examples/postgres/Main.hs b/domaindriven-effectful-examples/postgres/Main.hs index f03f5a2..86d63a7 100644 --- a/domaindriven-effectful-examples/postgres/Main.hs +++ b/domaindriven-effectful-examples/postgres/Main.hs @@ -4,7 +4,7 @@ import Control.Monad (when) import Data.Aeson import Database.PostgreSQL.Simple (connectPostgreSQL) import DomainDriven.Effectful -import DomainDriven.Effectful.Interpreter.Postgres +import DomainDriven.Persistance.Postgres (EventTable (..), PostgresEvent, postgresWriteModel, simplePool) import Effectful hiding ((:>)) import Effectful qualified import Effectful.Error.Static @@ -96,8 +96,8 @@ mkCounterServer backend = liftIO . runEff . runErrorNoCallStack @ServerError - . runAggregatePostgres backend - $ runProjectionPostgres backend m + . runAggregate backend + $ runProjection backend m either Servant.throwError pure a eventTable :: EventTable @@ -111,7 +111,7 @@ main = do let port = 7878 putStrLn $ "Running Effectful counter on port " <> show port - -- Initialize the in-memory backend + -- Initialize the PostgreSQL backend connectionPool <- simplePool $ connectPostgreSQL diff --git a/domaindriven-effectful-examples/simple/Main.hs b/domaindriven-effectful-examples/simple/Main.hs index 380f5f4..c5c32f1 100644 --- a/domaindriven-effectful-examples/simple/Main.hs +++ b/domaindriven-effectful-examples/simple/Main.hs @@ -3,7 +3,7 @@ module Main where import Control.Monad (when) import DomainDriven.Effectful -import DomainDriven.Effectful.Interpreter.InMemory +import DomainDriven.Persistance.ForgetfulInMemory (ForgetfulInMemory, createForgetful) import Effectful hiding ((:>)) import Effectful qualified import Effectful.Error.Static @@ -101,8 +101,8 @@ mkCounterServer backend = liftIO . runEff . runErrorNoCallStack @ServerError - . runAggregateInMemory backend - $ runProjectionInMemory backend m + . runAggregate backend + $ runProjection backend m either Servant.throwError pure a -------------------------------------------------------------------------------- diff --git a/domaindriven-effectful/domaindriven-effectful.cabal b/domaindriven-effectful/domaindriven-effectful.cabal index 67b3a2d..706413c 100644 --- a/domaindriven-effectful/domaindriven-effectful.cabal +++ b/domaindriven-effectful/domaindriven-effectful.cabal @@ -41,6 +41,7 @@ common shared_opts NoImplicitPrelude OverloadedLabels AllowAmbiguousTypes + BlockArguments OverloadedStrings PolyKinds RankNTypes @@ -75,23 +76,20 @@ library DomainDriven.Effectful DomainDriven.Effectful.Aggregate DomainDriven.Effectful.Domain - DomainDriven.Effectful.Interpreter.InMemory - DomainDriven.Effectful.Interpreter.Postgres + DomainDriven.Effectful.Interpreter DomainDriven.Effectful.Projection DomainDriven.FieldNameAsPath Servant.Auth.Internal.ThrowAll.SOP hs-source-dirs: src build-depends: - aeson - , base + base , bytestring , domaindriven-core , effectful-core , effectful-plugin , effectful-th , generics-sop - , hashable , openapi3 , servant-auth-server , servant-client-core diff --git a/domaindriven-effectful/src/DomainDriven/Effectful.hs b/domaindriven-effectful/src/DomainDriven/Effectful.hs index b616106..2b0ddf7 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful.hs +++ b/domaindriven-effectful/src/DomainDriven/Effectful.hs @@ -9,5 +9,6 @@ where import DomainDriven.Effectful.Aggregate as X import DomainDriven.Effectful.Domain +import DomainDriven.Effectful.Interpreter as X import DomainDriven.Effectful.Projection as X import DomainDriven.Persistance.Class as X (Indexed (..), NoIndex (..), Stored (..)) diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter.hs new file mode 100644 index 0000000..52cc433 --- /dev/null +++ b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter.hs @@ -0,0 +1,50 @@ +module DomainDriven.Effectful.Interpreter + ( runAggregate + , runProjection + ) where + +import DomainDriven.Effectful.Aggregate +import DomainDriven.Effectful.Domain +import DomainDriven.Effectful.Projection +import DomainDriven.Persistance.Class (ReadModel, WriteModel) +import DomainDriven.Persistance.Class qualified as P +import Effectful +import Effectful.Dispatch.Dynamic +import Prelude + +-- | Run the 'Projection' effect using any 'ReadModel' backend. +runProjection + :: forall backend domain es a + . ( IOE :> es + , ReadModel backend + , P.Model backend ~ DomainModel domain + , P.Event backend ~ DomainEvent domain + , P.Index backend ~ DomainIndex domain + ) + => backend + -> Eff (Projection domain : es) a + -> Eff es a +runProjection backend = interpret $ \_ -> \case + GetModelI idx -> liftIO $ P.getModel backend idx + GetEventListI idx -> liftIO $ P.getEventList backend idx + +-- | Run the 'Aggregate' effect using any 'WriteModel' backend. +-- +-- Delegates to 'P.runCmd' which fires 'postUpdateHook' asynchronously +-- after each transactional update, ensuring uniform hook behavior +-- regardless of backend. +runAggregate + :: forall backend domain es a + . ( IOE :> es + , WriteModel backend + , P.Model backend ~ DomainModel domain + , P.Event backend ~ DomainEvent domain + , P.Index backend ~ DomainIndex domain + ) + => backend + -> Eff (Aggregate domain : es) a + -> Eff es a +runAggregate backend = interpret $ \env -> \case + RunTransactionI idx cmd -> + localSeqUnlift env $ \unlift -> + P.runCmd backend idx $ unlift . cmd diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs deleted file mode 100644 index ebb7aff..0000000 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/InMemory.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -module DomainDriven.Effectful.Interpreter.InMemory - ( module DomainDriven.Effectful.Interpreter.InMemory - , createForgetful - , ForgetfulInMemory - ) where - -import Data.Hashable (Hashable) -import DomainDriven.Effectful.Aggregate -import DomainDriven.Effectful.Domain -import DomainDriven.Effectful.Projection -import DomainDriven.Persistance.Class (WriteModel) -import DomainDriven.Persistance.Class qualified as P -import DomainDriven.Persistance.ForgetfulInMemory -import Effectful -import Effectful.Dispatch.Dynamic -import Prelude - --- | Run the Projection' effect using an in-memory backend (new domain API) -runProjectionInMemory - :: forall domain es a - . (Hashable (DomainIndex domain), IOE :> es) - => ForgetfulInMemory (DomainModel domain) (DomainIndex domain) (DomainEvent domain) - -> Eff (Projection domain : es) a - -> Eff es a -runProjectionInMemory backend = interpret $ \_ -> \case - GetModelI idx -> liftIO $ P.getModel backend idx - GetEventListI idx -> liftIO $ P.getEventList backend idx - --- | Run the Aggregate effect using an in-memory backend (new domain API) -runAggregateInMemory - :: forall domain es a - . ( IOE :> es - , WriteModel - (ForgetfulInMemory (DomainModel domain) (DomainIndex domain) (DomainEvent domain)) - ) - => ForgetfulInMemory (DomainModel domain) (DomainIndex domain) (DomainEvent domain) - -> Eff (Aggregate domain : es) a - -> Eff es a -runAggregateInMemory backend = interpret $ \env -> \case - RunTransactionI idx cmd -> do - localSeqUnlift env $ \unlift -> do - (model', _, returnFun) <- - P.transactionalUpdate backend idx $ - unlift . cmd - pure $ returnFun model' diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs b/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs deleted file mode 100644 index e464aed..0000000 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter/Postgres.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -module DomainDriven.Effectful.Interpreter.Postgres - ( module DomainDriven.Effectful.Interpreter.Postgres - , module DomainDriven.Persistance.Postgres - ) where - -import Data.Aeson -import DomainDriven.Effectful.Aggregate -import DomainDriven.Effectful.Domain -import DomainDriven.Effectful.Projection -import DomainDriven.Persistance.Class (WriteModel) -import DomainDriven.Persistance.Class qualified as P -import DomainDriven.Persistance.Postgres -import Effectful -import Effectful.Dispatch.Dynamic -import Prelude - --- | Run the Projection' effect using an in-memory backend (new domain API) -runProjectionPostgres - :: forall domain es a index - . ( IOE :> es - , FromJSON (DomainEvent domain) - , IsPgIndex index - , index ~ (DomainIndex domain) - ) - => PostgresEvent (DomainIndex domain) (DomainModel domain) (DomainEvent domain) - -> Eff (Projection domain : es) a - -> Eff es a -runProjectionPostgres backend = interpret $ \_ -> \case - GetModelI idx -> liftIO $ P.getModel backend idx - GetEventListI idx -> liftIO $ P.getEventList backend idx - --- | Run the Aggregate effect using an in-memory backend (new domain API) -runAggregatePostgres - :: forall domain es a index - . ( IOE :> es - , index ~ (DomainIndex domain) - , WriteModel (PostgresEvent (DomainIndex domain) (DomainModel domain) (DomainEvent domain)) - ) - => PostgresEvent (DomainIndex domain) (DomainModel domain) (DomainEvent domain) - -> Eff (Aggregate domain : es) a - -> Eff es a -runAggregatePostgres backend = interpret $ \env -> \case - RunTransactionI idx cmd -> do - localSeqUnlift env $ \unlift -> - P.runCmd backend idx $ unlift . cmd diff --git a/domaindriven-effectful/test/DomainDriven/Effectful/InMemorySpec.hs b/domaindriven-effectful/test/DomainDriven/Effectful/InMemorySpec.hs index c1ddcb3..6f90840 100644 --- a/domaindriven-effectful/test/DomainDriven/Effectful/InMemorySpec.hs +++ b/domaindriven-effectful/test/DomainDriven/Effectful/InMemorySpec.hs @@ -2,12 +2,14 @@ module DomainDriven.Effectful.InMemorySpec (spec) where import DomainDriven.Effectful.Aggregate import DomainDriven.Effectful.Domain -import DomainDriven.Effectful.Interpreter.InMemory +import DomainDriven.Effectful.Interpreter import DomainDriven.Effectful.Projection import DomainDriven.Persistance.Class (Indexed (..), NoIndex (..), Stored (..)) -import DomainDriven.Persistance.ForgetfulInMemory () +import DomainDriven.Persistance.ForgetfulInMemory import Effectful import Test.Hspec +import Control.Concurrent.Chan (newChan, readChan, writeChan) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) import Prelude type TestModel = Int @@ -30,8 +32,18 @@ runTest -> IO a runTest backend = runEff - . runProjectionInMemory backend - . runAggregateInMemory backend + . runProjection backend + . runAggregate backend + +runTestWith + :: ForgetfulInMemory TestModel NoIndex TestEvent + -> (NoIndex -> TestModel -> [Stored TestEvent] -> IO ()) + -> Eff '[Aggregate TestDomain, Projection TestDomain, IOE] a + -> IO a +runTestWith backend hook = + runEff + . runProjection backend + . runAggregate (backend { updateHook = hook }) runIndexedTest :: ForgetfulInMemory TestModel Indexed TestEvent @@ -39,8 +51,8 @@ runIndexedTest -> IO a runIndexedTest backend = runEff - . runProjectionInMemory backend - . runAggregateInMemory backend + . runProjection backend + . runAggregate backend spec :: Spec spec = do @@ -88,3 +100,47 @@ spec = do mb <- runIndexedTest backend (getModelI @IndexedTestDomain (Indexed "b")) ma `shouldBe` 1 mb `shouldBe` 2 + + describe "PostUpdateHook" $ do + it "hook receives correct model and events" $ do + mvar <- newEmptyMVar + let hook _ model events = putMVar mvar (model, map storedEvent events) + backend <- createForgetful applyTestEvent (0 :: TestModel) + runTestWith backend hook $ + runTransaction @TestDomain $ \_ -> pure (const (), [AddOne, AddOne]) + result <- takeMVar mvar + result `shouldBe` (2, [AddOne, AddOne]) + + it "hook fires for each transaction" $ do + chan <- newChan + let hook _ _ _ = writeChan chan () + backend <- createForgetful applyTestEvent (0 :: TestModel) + runTestWith backend hook $ do + runTransaction @TestDomain $ \_ -> pure (const (), [AddOne]) + runTransaction @TestDomain $ \_ -> pure (const (), [AddOne]) + readChan chan + readChan chan + + it "hook fires once per transaction" $ do + mvar <- newEmptyMVar + let hook _ _ _ = putMVar mvar () + backend <- createForgetful applyTestEvent (0 :: TestModel) + runTestWith backend hook $ + runTransaction @TestDomain $ \_ -> pure (const (), [AddOne]) + takeMVar mvar + + it "failing hook does not crash the command" $ do + mvar <- newEmptyMVar + let hook _ _ _ = putMVar mvar () >> error "hook explosion" + backend <- createForgetful applyTestEvent (0 :: TestModel) + result <- runTestWith backend hook $ + runTransaction @TestDomain $ \_ -> pure (id, [AddOne]) + takeMVar mvar -- wait for hook to fire + result `shouldBe` 1 + + it "no-op hook does not affect behavior" $ do + backend <- createForgetful applyTestEvent (0 :: TestModel) + runTestWith backend (\_ _ _ -> pure ()) $ + runTransaction @TestDomain $ \_ -> pure (const (), [AddOne]) + m <- runTestWith backend (\_ _ _ -> pure ()) (getModel @TestDomain) + m `shouldBe` 1 diff --git a/run-ghcid.sh b/run-ghcid.sh index 8ed3397..7944377 100755 --- a/run-ghcid.sh +++ b/run-ghcid.sh @@ -17,13 +17,14 @@ echo "----------------------------------------" # - output redirected to log file # # -components=$(gen-hie |grep component|grep '".*"' -o|sed "s:\"::g" | xargs echo) +components=$(gen-hie |grep component|grep '".*"' -o|sed "s:\"::g" | sort -u | xargs echo) echo cabal v2-repl --enable-multi-repl $components ghcid \ --command "cabal v2-repl --enable-multi-repl $components" \ --restart "cabal.project" \ - --restart "streaker.cabal" \ - --restart "chatcompletion-effectful.cabal" \ + --restart "domaindriven-core/domaindriven-core.cabal" \ + --restart "domaindriven-effectful/domaindriven-effectful.cabal" \ + --restart "domaindriven-effectful-examples/domaindriven-effectful-examples.cabal" \ -o $LOG_FILE diff --git a/specs/generalized-read-model.md b/specs/generalized-read-model.md deleted file mode 100644 index 8134334..0000000 --- a/specs/generalized-read-model.md +++ /dev/null @@ -1,133 +0,0 @@ -# Generalized `ReadModel` - -This iteration incorporates two refinements: - -1. No defaults inside the class. Defining a `ReadModel` is rare and explicit implementations keep behaviour obvious. -2. The `Model p` associated type is removed. Backends now commit only to their runtime `ResolvableModel` and query surface. - -## Supporting types - -```haskell -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} - -newtype StateQuery state r = StateQuery - { runStateQuery :: state -> r - } - -identityQuery :: StateQuery s s -identityQuery = StateQuery id - -data BeamQuery be db r where - BeamQuery :: (forall m. MonadBeam be m => db -> m r) -> BeamQuery be db r -``` - -The helper newtypes are optional; each backend chooses its own `Query p` type alias. - -## Proposed class - -```haskell -class ReadModel p where - type Event p :: Type -- The event type - type Index p :: Type -- Index. can be unit if not applicable. - type ResolvableModel p :: Type -- Could be the model itself, or some way of fetching it in `RunnerMonad p` - type RunnerMonad p :: Type -> Type -- The Monad where `applyEvent` and `queryModel` runs. - type Query p :: Type -> Type -- The types of queries that can be run. Identity for in memory models. - - applyEvent - :: p - -> Index p - -> Stored (Event p) - -> ResolvableModel p - -> RunnerMonad p (ResolvableModel p) - - queryModel - :: p -> Index p -> Query p r -> RunnerMonad p r - - getEventList :: p -> Index p -> IO [Stored (Event p)] - getEventStream :: HasCallStack => p -> Index p -> Stream IO (Stored (Event p)) -``` - -Every backend must explicitly choose its `RunnerMonad`, `ResolvableModel`, and `Query` carrier. There are no defaults. - -## In-memory instance - -```haskell -instance Hashable index => ReadModel (ForgetfulInMemory model index event) where - type Event (ForgetfulInMemory model index event) = event - type Index (ForgetfulInMemory model index event) = index - type ResolvableModel (ForgetfulInMemory model index event) = model - type RunnerMonad (ForgetfulInMemory model index event) = IO - type Query (ForgetfulInMemory model index event) = StateQuery model - - -- transactionalUpdate in the backend reads the current state from stateRef - -- and supplies it here as `model`. - applyEvent ff _ stored model = - pure (apply ff model stored) - - queryModel ff idx (StateQuery k) = do - state <- HM.lookupDefault (seed ff) idx <$> readIORef (stateRef ff) - pure (k state) - - getEventList ff idx = - HM.lookupDefault [] idx <$> readIORef (events ff) - - getEventStream ff idx = - Stream.bracketIO - (HM.lookupDefault [] idx <$> readIORef (events ff)) - (const (pure ())) - Stream.fromList -``` - -`StateQuery` lets callers recover the old behaviour (`identityQuery` yields the whole model) or project fields without additional boilerplate. - -## Beam/Postgres instance - -```haskell -data BeamReadModel = BeamReadModel - { pool :: Pool Connection - , db :: DatabaseSettings Postgres UserDb - } - -instance HasEventProjection UserEvent => ReadModel BeamReadModel where - type Event BeamReadModel = UserEvent - type Index BeamReadModel = UUID - type ResolvableModel BeamReadModel = BeamHandle Postgres Connection UserDb - type RunnerMonad BeamReadModel = BeamTx Postgres Connection - type Query BeamReadModel = BeamQuery Postgres UserDb - - applyEvent _ userId stored handle = - runBeamUpdate handle (mkEventProjectionQuery userId stored) - - queryModel BeamReadModel{pool, db} _ (BeamQuery q) = - withResource pool $ \conn -> runBeamPostgres conn (q db) - - getEventList = ... - getEventStream = ... -``` - -No materialised Haskell model is created unless a query requests it. Users express read patterns by constructing `BeamQuery` values: - -```haskell -latestBalance :: UUID -> BeamQuery Postgres UserDb (Maybe Balance) -latestBalance accountId = BeamQuery $ \db -> - runSelectReturningOne $ select $ do - row <- all_ (dbAccountBalance db) - guard_ (row.accountId ==. val_ accountId) - pure row.balance -``` - -## Pros - -* Backends are explicit about every capability (`RunnerMonad`, `ResolvableModel`, `Query`), making behaviour easy to audit. -* Pure backends still feel lightweight—`StateQuery` gives them the same ergonomics as before. -* Persistent backends expose typed query interfaces instead of serialising huge projections. -* The core library no longer needs to know anything about backend-specific model types. - -## Cons - -* Implementations must fill in all hooks; no defaults means more code per backend, though the count of backends is small. -* Callers must evaluate the chosen `RunnerMonad` (`Either`, `BeamTx`, etc.), which may need shims at call sites. -* Additional associated types surface in type errors. -* Each backend has to design a query language (`StateQuery`, `BeamQuery`) and maintain it as part of its API. From 15a3a2ce0ef8b9214a4315bdc52f24d187550940 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Wed, 25 Feb 2026 13:17:05 +0100 Subject: [PATCH 47/50] Better examples --- README.md | 13 +- domaindriven-effectful-examples/README.md | 42 ++++-- .../domaindriven-effectful-examples.cabal | 21 ++- .../fieldname-as-path/Main.hs | 140 ++++++++++++++++++ .../postgres/Event/V1.hs | 24 +-- .../postgres/Event/V2.hs | 28 +--- .../postgres/EventMigration.hs | 53 +++---- .../postgres/Main.hs | 59 ++++---- .../simple/Main.hs | 34 ++++- 9 files changed, 277 insertions(+), 137 deletions(-) create mode 100644 domaindriven-effectful-examples/fieldname-as-path/Main.hs diff --git a/README.md b/README.md index c46bba3..c9f1f81 100644 --- a/README.md +++ b/README.md @@ -1,14 +1,11 @@ # DomainDriven -DomainDriven is a batteries included synchronous event sourcing and CQRS library. It is split into two parts: - -- [domaindriven-core](domaindriven-core) Contains the core persistance model as well as postgres and in-memory backend. -- [domaindriven](domaindriven) Introduces a convenient way of specifying actions using GADTs and TemplateHaskell. -- [domaindriven](domaindriven-examples) Examples of how to use domaindriven. +DomainDriven is a batteries included synchronous event sourcing and CQRS library. It is split into the following packages: +- [domaindriven-core](domaindriven-core) - Core persistence model with PostgreSQL and in-memory backends. +- [domaindriven-effectful](domaindriven-effectful) - Effectful-based API layer with `Aggregate` and `Projection` effects, plus Servant integration. +- [domaindriven-effectful-examples](domaindriven-effectful-examples) - Example applications demonstrating usage. ## Design idea -The core idea it to do synchronous event sourcing with locks and thereby provide the upsides of event sourcing without the extra complexity introduced by asynchrnous workflows. - - +The core idea is to do synchronous event sourcing with locks and thereby provide the upsides of event sourcing without the extra complexity introduced by asynchronous workflows. diff --git a/domaindriven-effectful-examples/README.md b/domaindriven-effectful-examples/README.md index 31cf552..69941d3 100644 --- a/domaindriven-effectful-examples/README.md +++ b/domaindriven-effectful-examples/README.md @@ -1,29 +1,43 @@ # DomainDriven Effectful Examples Example applications demonstrating the Effectful-based domaindriven library. +All three examples use a simple counter domain to keep the focus on the library features. ## Examples -### Simple Counter -Basic counter application using Effectful effects with standard Servant API. +### 1. Simple Counter (`simple/`) +Getting started example with in-memory persistence. No database required. + +Features: model/event/applyEvent pattern, Aggregate & Projection effects, `GET /events` endpoint. -Run with: ```bash -cabal run simple-example +cabal run simple-example # starts on port 7878 +curl localhost:7878 # get counter value +curl -X POST localhost:7878/increase +curl localhost:7878/events # list stored events ``` -### Postgres Example -Counter application with PostgreSQL persistence and event migration. +### 2. PostgreSQL + Event Migration (`postgres/`) +Counter with PostgreSQL persistence and event schema evolution. + +Features: `simplePool` connection pooling, `postgresWriteModel`, event migration from V1 (unit events) to V2 (events with Int payload) via `ShapeCoercible` and `MigrateUsing`. -Run with: +Requires a running PostgreSQL instance: ```bash -cabal run postgres-example +createdb -U postgres domaindriven ``` -## Features Demonstrated +```bash +cabal run postgres-example # starts on port 7879 (requires PostgreSQL) +curl -X POST -H 'Content-Type: application/json' -d '5' localhost:7879/increase +curl localhost:7879 +``` -- Using standard Servant combinators (`Get`, `Post`) instead of custom ones -- Effectful effects for domain logic -- In-memory and PostgreSQL persistence backends -- Type-safe effect composition -- Event versioning and migration +### 3. FieldNameAsPath (`fieldname-as-path/`) +Same counter as `simple/`, but uses `FieldNameAsPathApi` so record field names become URL paths automatically — no explicit path strings needed. + +```bash +cabal run fieldname-as-path-example # starts on port 7880 +curl localhost:7880/get +curl -X POST localhost:7880/increase +``` diff --git a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal index b6dd94e..12f69b8 100644 --- a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal +++ b/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal @@ -92,8 +92,6 @@ executable postgres-example , postgresql-simple , servant , servant-server - , text - , uuid , warp executable simple-example @@ -101,6 +99,25 @@ executable simple-example main-is: Main.hs hs-source-dirs: simple + build-depends: + aeson + , base + , domaindriven-core + , domaindriven-effectful + , effectful + , effectful-core + , effectful-plugin + , servant + , servant-server + , time + , uuid + , warp + +executable fieldname-as-path-example + import: shared_opts + main-is: Main.hs + hs-source-dirs: + fieldname-as-path build-depends: aeson , base diff --git a/domaindriven-effectful-examples/fieldname-as-path/Main.hs b/domaindriven-effectful-examples/fieldname-as-path/Main.hs new file mode 100644 index 0000000..4727ea5 --- /dev/null +++ b/domaindriven-effectful-examples/fieldname-as-path/Main.hs @@ -0,0 +1,140 @@ +-- | FieldNameAsPath — record field names become URL path segments automatically. +-- +-- Demonstrates: +-- * FieldNameAsPathApi: wraps a Servant Generic record so field names become paths +-- * FieldNameAsPathServer: serves the wrapped API +-- * Same counter domain as simple/, different routing approach +-- +-- Endpoints: GET /get, POST /increase, POST /decrease +-- (no "increase" :> or "decrease" :> needed in the API definition) +{-# LANGUAGE OverloadedRecordDot #-} +module Main where + +import Control.Monad (when) +import Data.Aeson (FromJSON, ToJSON) +import DomainDriven.Effectful +import DomainDriven.FieldNameAsPath +import DomainDriven.Persistance.ForgetfulInMemory (ForgetfulInMemory, createForgetful) +import Effectful hiding ((:>)) +import Effectful qualified +import Effectful.Error.Static +import Network.Wai.Handler.Warp (run) +import Servant hiding (throwError) +import Servant qualified +import Servant.API.Generic +import Servant.Server.Generic (AsServerT) +import Prelude + +-------------------------------------------------------------------------------- +-- Define the model +-------------------------------------------------------------------------------- +data CounterModel = CounterModel + { counter :: Int + , previousCounter :: Int + } + deriving (Show, Generic) + +-------------------------------------------------------------------------------- +-- Define events +-------------------------------------------------------------------------------- +data CounterEvent + = CounterIncreased + | CounterDecreased + deriving (Show, Generic, ToJSON, FromJSON) + +-------------------------------------------------------------------------------- +-- Define event handler +-------------------------------------------------------------------------------- +applyEvent :: CounterModel -> Stored CounterEvent -> CounterModel +applyEvent (CounterModel i _) (Stored ev _timestamp _uuid) = case ev of + CounterIncreased -> CounterModel (i + 1) i + CounterDecreased -> CounterModel (i - 1) i + +-------------------------------------------------------------------------------- +-- Define the API — field names become paths automatically +-------------------------------------------------------------------------------- + +-- | No path strings needed: /get, /increase, /decrease are derived from field names. +data CounterAPI mode = CounterAPI + { get :: mode :- Get '[JSON] Int + , increase :: mode :- Post '[JSON] Int + , decrease :: mode :- Post '[JSON] Int + } + deriving (Generic) + +-- | Use default apiTagFromLabel (= id), so field name is used as-is. +instance ApiTagFromLabel CounterAPI + +-------------------------------------------------------------------------------- +-- Implement the server handlers +-------------------------------------------------------------------------------- + +type CounterDomain = Domain CounterModel CounterEvent NoIndex + +counterServer + :: ( Projection CounterDomain Effectful.:> es + , Aggregate CounterDomain Effectful.:> es + , Error ServerError Effectful.:> es + ) + => CounterAPI (AsServerT (Eff es)) +counterServer = + CounterAPI + { get = do + CounterModel {counter} <- getModel + pure counter + , increase = runTransaction \_ -> do + pure (\a -> a.counter, [CounterIncreased]) + , decrease = runTransaction \m -> do + when + (m.counter <= 0) + (throwError err422{errBody = "Counter cannot go below zero"}) + pure (\a -> a.counter, [CounterDecreased]) + } + +-------------------------------------------------------------------------------- +-- Create the servant application using FieldNameAsPath +-------------------------------------------------------------------------------- + +-- Note: we use serve/hoistServer instead of genericServeT because +-- FieldNameAsPathApi provides its own HasServer instance that derives +-- paths from field names. +mkCounterServer + :: ForgetfulInMemory CounterModel NoIndex CounterEvent + -> Application +mkCounterServer backend = + serve (Proxy @(FieldNameAsPathApi CounterAPI)) + $ hoistServer (Proxy @(FieldNameAsPathApi CounterAPI)) runEffects + $ FieldNameAsPathServer counterServer + where + runEffects + :: Eff + '[ Projection CounterDomain + , Aggregate CounterDomain + , Error ServerError + , IOE + ] + a + -> Handler a + runEffects m = do + a <- + liftIO + . runEff + . runErrorNoCallStack @ServerError + . runAggregate backend + $ runProjection backend m + either Servant.throwError pure a + +-------------------------------------------------------------------------------- +-- Run the server +-------------------------------------------------------------------------------- +main :: IO () +main = do + let port = 7880 + putStrLn $ "Running FieldNameAsPath counter on port " <> show port + putStrLn " Endpoints: GET /get, POST /increase, POST /decrease" + + -- Initialize the in-memory backend + backend <- createForgetful applyEvent (CounterModel 0 0) + + -- Create and run the application + run port $ mkCounterServer backend diff --git a/domaindriven-effectful-examples/postgres/Event/V1.hs b/domaindriven-effectful-examples/postgres/Event/V1.hs index fb0b358..06a84d4 100644 --- a/domaindriven-effectful-examples/postgres/Event/V1.hs +++ b/domaindriven-effectful-examples/postgres/Event/V1.hs @@ -1,28 +1,10 @@ module Event.V1 where -import Data.Text (Text) -import Data.UUID (UUID) import Data.Aeson (FromJSON, ToJSON) import GHC.Generics (Generic) import Prelude -type UserId = UUID - -data Event - = UserEvent UserId UserEvent - | InventoryEvent InventoryEvent - deriving (Show, Generic, FromJSON, ToJSON) - -data UserEvent - = UserCreated {userName :: Text} - | UserNameChanged {newUserName :: Text} - deriving (Show, Generic, FromJSON, ToJSON) - -data InventoryEvent - = ItemAdded - { itemId :: UUID - , itemName :: Text - , quantity :: Int - } - | ItemRenamed {itemId :: UUID, itemName :: Text} +data CounterEvent + = CounterIncreased + | CounterDecreased deriving (Show, Generic, FromJSON, ToJSON) diff --git a/domaindriven-effectful-examples/postgres/Event/V2.hs b/domaindriven-effectful-examples/postgres/Event/V2.hs index afba5c0..316c01b 100644 --- a/domaindriven-effectful-examples/postgres/Event/V2.hs +++ b/domaindriven-effectful-examples/postgres/Event/V2.hs @@ -1,30 +1,10 @@ module Event.V2 where -import Data.Text (Text) -import Data.UUID (UUID) +import Data.Aeson (FromJSON, ToJSON) import GHC.Generics (Generic) import Prelude -import Data.Aeson (FromJSON, ToJSON) - -type UserId = UUID - -data Event - = UserEvent UserId UserEvent - | InventoryEvent InventoryEvent - deriving (Show, Generic, FromJSON, ToJSON) - -data UserEvent - = UserCreated {userName :: Text} - | UserNameChanged {newUserName :: Text} - | UserDeleted - deriving (Show, Generic, FromJSON, ToJSON) -data InventoryEvent - = ItemAdded - { itemId :: UUID - , itemName :: Text - , quantity :: Int - } - | ItemRenamed {itemId :: UUID, itemName :: Text} +data CounterEvent + = CounterIncreasedBy Int + | CounterDecreasedBy Int deriving (Show, Generic, FromJSON, ToJSON) - diff --git a/domaindriven-effectful-examples/postgres/EventMigration.hs b/domaindriven-effectful-examples/postgres/EventMigration.hs index ae4b1bc..d2ef708 100644 --- a/domaindriven-effectful-examples/postgres/EventMigration.hs +++ b/domaindriven-effectful-examples/postgres/EventMigration.hs @@ -1,58 +1,47 @@ -{-# options_GHC -Wno-orphans #-} -module EventMigration where +{-# OPTIONS_GHC -Wno-orphans #-} +module EventMigration (eventTable) where -import Prelude import Data.ShapeCoerce +import Database.PostgreSQL.Simple (Connection) import DomainDriven.Persistance.Class import DomainDriven.Persistance.Postgres -import Database.PostgreSQL.Simple (Connection) import DomainDriven.Persistance.Postgres.Migration import Event.V1 qualified as V1 import Event.V2 qualified as V2 +import Prelude - - -fixEvent :: Stored V1.Event -> Stored V2.Event +fixEvent :: Stored V1.CounterEvent -> Stored V2.CounterEvent fixEvent = shapeCoerce --- /home/tommy/git/domaindriven/domaindriven-effectful-examples/postgres/EventMigra --- tion.hs:16:12: error: [GHC-64725] +-- Automatic ShapeCoercible fails because the constructor names changed: +-- -- • Cannot shapeCoerce between types: --- From: V1.UserEvent --- To: V2.UserEvent +-- From: V1.CounterEvent +-- To: V2.CounterEvent -- --- Reason: Left side has a single constructor but right side is a sum type --- Left constructor: "UserNameChanged" --- Right side: Multiple constructors (sum type) +-- Reason: Constructor name mismatch +-- 'CounterIncreased ≠ 'CounterIncreasedBy -- --- Solution: Write instance `ShapeCoercible V1.UserEvent V2.UserEvent` --- • In the expression: shapeCoerce --- In an equation for ‘fixEvent’: fixEvent = shapeCoerce --- | --- 16 | fixEvent = shapeCoerce --- | ^^^^^^^^^^^ --- -- | V2.UserEvent has a new constructor +-- Solution: Write instance `ShapeCoercible V1.CounterEvent V2.CounterEvent` -instance ShapeCoercible V1.UserEvent V2.UserEvent where - shapeCoerce = \case - V1.UserCreated name -> V2.UserCreated name - V1.UserNameChanged name -> V2.UserNameChanged name +instance ShapeCoercible V1.CounterEvent V2.CounterEvent where + shapeCoerce = \case + V1.CounterIncreased -> V2.CounterIncreasedBy 1 + V1.CounterDecreased -> V2.CounterDecreasedBy 1 migrate :: PreviousEventTableName -> EventTableName -> Connection -> IO () -migrate prevEtname etName conn = do +migrate prevEtName etName conn = do migrate1to1 @NoIndex conn - prevEtname + prevEtName etName fixEvent eventTable :: EventTable -eventTable = MigrateUsing migrate - $ InitialVersion "my_events" - - - +eventTable = + MigrateUsing migrate + $ InitialVersion "counter_events" diff --git a/domaindriven-effectful-examples/postgres/Main.hs b/domaindriven-effectful-examples/postgres/Main.hs index 86d63a7..7163ce4 100644 --- a/domaindriven-effectful-examples/postgres/Main.hs +++ b/domaindriven-effectful-examples/postgres/Main.hs @@ -1,13 +1,21 @@ +-- | PostgreSQL persistence with event migration. +-- +-- Demonstrates: +-- * PostgresEvent backend with connection pooling (simplePool) +-- * Event versioning: V1 (unit events) → V2 (events with Int payload) +-- * Wiring an EventTable with MigrateUsing into postgresWriteModel +-- * ReqBody for parameterised commands module Main where import Control.Monad (when) -import Data.Aeson import Database.PostgreSQL.Simple (connectPostgreSQL) import DomainDriven.Effectful -import DomainDriven.Persistance.Postgres (EventTable (..), PostgresEvent, postgresWriteModel, simplePool) +import DomainDriven.Persistance.Postgres (PostgresEvent, postgresWriteModel, simplePool) import Effectful hiding ((:>)) import Effectful qualified import Effectful.Error.Static +import Event.V2 +import EventMigration (eventTable) import Network.Wai.Handler.Warp (run) import Servant hiding (throwError) import Servant qualified @@ -21,39 +29,29 @@ import Prelude type CounterModel = Int -------------------------------------------------------------------------------- --- Define events --------------------------------------------------------------------------------- -data CounterEvent - = Increase - | Decrease - deriving (Show, Generic, ToJSON, FromJSON) - --------------------------------------------------------------------------------- --- Define event handler +-- Define event handler (using V2 events) -------------------------------------------------------------------------------- applyEvent :: CounterModel -> Stored CounterEvent -> CounterModel applyEvent i (Stored ev _timestamp _uuid) = case ev of - Increase -> i + 1 - Decrease -> i - 1 + CounterIncreasedBy n -> i + n + CounterDecreasedBy n -> i - n --- Define the domain, used to cary the type constraints +-- | Domain type carrying model, event, and index constraints. type CounterDomain = Domain CounterModel CounterEvent NoIndex -------------------------------------------------------------------------------- --- Use Servant to define the Commands +-- Use Servant to define the API -------------------------------------------------------------------------------- data CounterAPI mode = CounterAPI { get :: mode :- Get '[JSON] Int - , increase :: mode :- "increase" :> Post '[JSON] Int - , decrease :: mode :- "decrease" :> Post '[JSON] Int + , increase :: mode :- "increase" :> ReqBody '[JSON] Int :> Post '[JSON] Int + , decrease :: mode :- "decrease" :> ReqBody '[JSON] Int :> Post '[JSON] Int } deriving (Generic) -------------------------------------------------------------------------------- -- Implement the server handlers using Effectful effects -------------------------------------------------------------------------------- - --- | Counter handlers using Effectful effects counterServer :: ( Projection CounterDomain Effectful.:> es , Aggregate CounterDomain Effectful.:> es @@ -63,18 +61,17 @@ counterServer counterServer = CounterAPI { get = getModel - , increase = runTransaction \_ -> do - pure (id, [Increase]) - , decrease = runTransaction \m -> do + , increase = \amount -> runTransaction \_ -> do + pure (id, [CounterIncreasedBy amount]) + , decrease = \amount -> runTransaction \m -> do when - (m <= 0) + (m - amount < 0) (throwError err422{errBody = "Counter cannot go below zero"}) - pure (id, [Decrease]) + pure (id, [CounterDecreasedBy amount]) } -------------------------------------------------------------------------------- --- Create the servant application. --- Here we have to run all the effects and transform it to Servant's Handler monad. +-- Create the servant application -------------------------------------------------------------------------------- mkCounterServer :: PostgresEvent NoIndex CounterModel CounterEvent @@ -100,18 +97,15 @@ mkCounterServer backend = $ runProjection backend m either Servant.throwError pure a -eventTable :: EventTable -eventTable = InitialVersion "counter_events" - -------------------------------------------------------------------------------- -- Run the server -------------------------------------------------------------------------------- main :: IO () main = do - let port = 7878 - putStrLn $ "Running Effectful counter on port " <> show port + let port = 7879 + putStrLn $ "Running Effectful counter (Postgres) on port " <> show port - -- Initialize the PostgreSQL backend + -- Initialize the PostgreSQL backend with event migration connectionPool <- simplePool $ connectPostgreSQL @@ -122,5 +116,6 @@ main = do eventTable applyEvent (0 :: CounterModel) + -- Create and run the application run port $ mkCounterServer backend diff --git a/domaindriven-effectful-examples/simple/Main.hs b/domaindriven-effectful-examples/simple/Main.hs index c5c32f1..0d6e4b7 100644 --- a/domaindriven-effectful-examples/simple/Main.hs +++ b/domaindriven-effectful-examples/simple/Main.hs @@ -1,7 +1,17 @@ +-- | Getting Started — basic counter with in-memory persistence. +-- +-- Demonstrates: +-- * Defining a model, events, and applyEvent +-- * Using Servant Generic API with Effectful effects (Aggregate & Projection) +-- * ForgetfulInMemory backend (no database required) +-- * GET /events endpoint via getEventList {-# LANGUAGE OverloadedRecordDot #-} module Main where import Control.Monad (when) +import Data.Aeson (FromJSON, ToJSON) +import Data.Time (UTCTime) +import Data.UUID (UUID) import DomainDriven.Effectful import DomainDriven.Persistance.ForgetfulInMemory (ForgetfulInMemory, createForgetful) import Effectful hiding ((:>)) @@ -18,7 +28,7 @@ import Prelude -- Define the model -------------------------------------------------------------------------------- data CounterModel = CounterModel - { counter :: Int + { counter :: Int , previousCounter :: Int } deriving (Show, Generic) @@ -29,7 +39,7 @@ data CounterModel = CounterModel data CounterEvent = CounterIncreased | CounterDecreased - deriving (Show) + deriving (Show, Generic, ToJSON, FromJSON) -------------------------------------------------------------------------------- -- Define event handler @@ -41,12 +51,22 @@ applyEvent (CounterModel i _) (Stored ev _timestamp _uuid) = case ev of -------------------------------------------------------------------------------- --- Use Servant to define the Commands +-- Use Servant to define the API -------------------------------------------------------------------------------- + +-- | Envelope for returning stored events over JSON. +data StoredEvent = StoredEvent + { event :: CounterEvent + , timestamp :: UTCTime + , uuid :: UUID + } + deriving (Show, Generic, ToJSON) + data CounterAPI mode = CounterAPI { get :: mode :- Get '[JSON] Int , increase :: mode :- "increase" :> Post '[JSON] Int , decrease :: mode :- "decrease" :> Post '[JSON] Int + , events :: mode :- "events" :> Get '[JSON] [StoredEvent] } deriving (Generic) @@ -69,13 +89,19 @@ counterServer = CounterModel {counter} <- getModel pure counter , increase = runTransaction \_ -> do - pure (\a -> a.counter , [CounterIncreased]) + pure (\a -> a.counter, [CounterIncreased]) , decrease = runTransaction \m -> do when (m.counter <= 0) (throwError err422{errBody = "Counter cannot go below zero"}) pure (\a -> a.counter, [CounterDecreased]) + , events = do + storedEvents <- getEventList + pure $ map toStoredEvent storedEvents } + where + toStoredEvent :: Stored CounterEvent -> StoredEvent + toStoredEvent (Stored ev ts uid) = StoredEvent ev ts uid -------------------------------------------------------------------------------- -- Create the servant application. From 1dd490e5544e0c93e460a68cbb806f962d8ef0d9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Wed, 25 Feb 2026 14:18:22 +0100 Subject: [PATCH 48/50] rename modules --- CLAUDE.md | 10 +++++----- README.md | 4 ++-- cabal.project | 4 ++-- .../src/DomainDriven/Effectful.hs | 14 -------------- .../README.md | 4 ++-- .../domaindriven-examples.cabal | 12 ++++++------ .../fieldname-as-path/Main.hs | 2 +- .../intro.txt | 0 .../postgres/Event/V1.hs | 0 .../postgres/Event/V2.hs | 0 .../postgres/EventMigration.hs | 0 .../postgres/Main.hs | 2 +- .../simple/Main.hs | 2 +- .../README.md | 0 .../domaindriven.cabal | 18 +++++++++--------- domaindriven/src/DomainDriven.hs | 14 ++++++++++++++ .../src/DomainDriven}/Aggregate.hs | 4 ++-- .../src/DomainDriven}/Domain.hs | 4 ++-- .../src/DomainDriven/FieldNameAsPath.hs | 0 .../src/DomainDriven}/Interpreter.hs | 8 ++++---- .../src/DomainDriven}/Projection.hs | 4 ++-- .../src/Servant/Auth/Internal/ThrowAll/SOP.hs | 0 .../test/DomainDriven}/InMemorySpec.hs | 10 +++++----- .../test/Spec.hs | 0 flake.nix | 1 + run-ghcid.sh | 4 ++-- 26 files changed, 61 insertions(+), 60 deletions(-) delete mode 100644 domaindriven-effectful/src/DomainDriven/Effectful.hs rename {domaindriven-effectful-examples => domaindriven-examples}/README.md (92%) rename domaindriven-effectful-examples/domaindriven-effectful-examples.cabal => domaindriven-examples/domaindriven-examples.cabal (90%) rename {domaindriven-effectful-examples => domaindriven-examples}/fieldname-as-path/Main.hs (99%) rename {domaindriven-effectful-examples => domaindriven-examples}/intro.txt (100%) rename {domaindriven-effectful-examples => domaindriven-examples}/postgres/Event/V1.hs (100%) rename {domaindriven-effectful-examples => domaindriven-examples}/postgres/Event/V2.hs (100%) rename {domaindriven-effectful-examples => domaindriven-examples}/postgres/EventMigration.hs (100%) rename {domaindriven-effectful-examples => domaindriven-examples}/postgres/Main.hs (99%) rename {domaindriven-effectful-examples => domaindriven-examples}/simple/Main.hs (99%) rename {domaindriven-effectful => domaindriven}/README.md (100%) rename domaindriven-effectful/domaindriven-effectful.cabal => domaindriven/domaindriven.cabal (88%) create mode 100644 domaindriven/src/DomainDriven.hs rename {domaindriven-effectful/src/DomainDriven/Effectful => domaindriven/src/DomainDriven}/Aggregate.hs (92%) rename {domaindriven-effectful/src/DomainDriven/Effectful => domaindriven/src/DomainDriven}/Domain.hs (86%) rename {domaindriven-effectful => domaindriven}/src/DomainDriven/FieldNameAsPath.hs (100%) rename {domaindriven-effectful/src/DomainDriven/Effectful => domaindriven/src/DomainDriven}/Interpreter.hs (90%) rename {domaindriven-effectful/src/DomainDriven/Effectful => domaindriven/src/DomainDriven}/Projection.hs (93%) rename {domaindriven-effectful => domaindriven}/src/Servant/Auth/Internal/ThrowAll/SOP.hs (100%) rename {domaindriven-effectful/test/DomainDriven/Effectful => domaindriven/test/DomainDriven}/InMemorySpec.hs (96%) rename {domaindriven-effectful => domaindriven}/test/Spec.hs (100%) diff --git a/CLAUDE.md b/CLAUDE.md index d8588cc..be0aedb 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -5,9 +5,9 @@ This file provides guidance to Claude Code (claude.ai/code) when working with co ## Build Commands - **Build all packages**: `cabal build all` -- **Build specific package**: `cabal build domaindriven-effectful` +- **Build specific package**: `cabal build domaindriven` - **Run tests**: `cabal test all` -- **Run specific test**: `cabal test domaindriven-effectful` +- **Run specific test**: `cabal test domaindriven` - **Clean build**: `cabal clean` ## Architecture Overview @@ -22,11 +22,11 @@ DomainDriven is a synchronous event sourcing and CQRS library split into multipl - `Postgres`: Production persistence with transactional guarantees - Synchronous event sourcing with locks to avoid eventual consistency issues -- **domaindriven-effectful**: Experimental Effectful-based implementation +- **domaindriven**: Effectful-based API layer - Uses standard Servant combinators instead of custom ones - Two main effects: `Aggregate` (commands) and `Projection` (queries) - Dynamic dispatch interpreters for different backends - - Located in `domaindriven-effectful/` + - Located in `domaindriven/` ### Key Design Patterns @@ -49,5 +49,5 @@ DomainDriven is a synchronous event sourcing and CQRS library split into multipl - All packages use extensive language extensions (see .cabal files) - Strict warning settings (`-Wall -Werror`) - fix all warnings before committing -- The Effectful prototype aims to simplify the API while maintaining type safety +- The Effectful layer aims to simplify the API while maintaining type safety - Tests use `hspec` framework with in-memory backends \ No newline at end of file diff --git a/README.md b/README.md index c9f1f81..61c6dca 100644 --- a/README.md +++ b/README.md @@ -3,8 +3,8 @@ DomainDriven is a batteries included synchronous event sourcing and CQRS library. It is split into the following packages: - [domaindriven-core](domaindriven-core) - Core persistence model with PostgreSQL and in-memory backends. -- [domaindriven-effectful](domaindriven-effectful) - Effectful-based API layer with `Aggregate` and `Projection` effects, plus Servant integration. -- [domaindriven-effectful-examples](domaindriven-effectful-examples) - Example applications demonstrating usage. +- [domaindriven](domaindriven) - Effectful-based API layer with `Aggregate` and `Projection` effects, plus Servant integration. +- [domaindriven-examples](domaindriven-examples) - Example applications demonstrating usage. ## Design idea diff --git a/cabal.project b/cabal.project index 9d89ce4..8f9bad0 100644 --- a/cabal.project +++ b/cabal.project @@ -1,7 +1,7 @@ packages: domaindriven-core/ - domaindriven-effectful/ - domaindriven-effectful-examples/ + domaindriven/ + domaindriven-examples/ -- Use Stackage LTS 24.2 as the main package source import: https://www.stackage.org/lts-24.31/cabal.config diff --git a/domaindriven-effectful/src/DomainDriven/Effectful.hs b/domaindriven-effectful/src/DomainDriven/Effectful.hs deleted file mode 100644 index 2b0ddf7..0000000 --- a/domaindriven-effectful/src/DomainDriven/Effectful.hs +++ /dev/null @@ -1,14 +0,0 @@ -module DomainDriven.Effectful - ( -- * Domain configuration (re-exported) - module DomainDriven.Effectful.Domain - - -- * Effects and helpers - , module X - ) -where - -import DomainDriven.Effectful.Aggregate as X -import DomainDriven.Effectful.Domain -import DomainDriven.Effectful.Interpreter as X -import DomainDriven.Effectful.Projection as X -import DomainDriven.Persistance.Class as X (Indexed (..), NoIndex (..), Stored (..)) diff --git a/domaindriven-effectful-examples/README.md b/domaindriven-examples/README.md similarity index 92% rename from domaindriven-effectful-examples/README.md rename to domaindriven-examples/README.md index 69941d3..9c47d2d 100644 --- a/domaindriven-effectful-examples/README.md +++ b/domaindriven-examples/README.md @@ -1,6 +1,6 @@ -# DomainDriven Effectful Examples +# DomainDriven Examples -Example applications demonstrating the Effectful-based domaindriven library. +Example applications demonstrating the domaindriven library. All three examples use a simple counter domain to keep the focus on the library features. ## Examples diff --git a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal b/domaindriven-examples/domaindriven-examples.cabal similarity index 90% rename from domaindriven-effectful-examples/domaindriven-effectful-examples.cabal rename to domaindriven-examples/domaindriven-examples.cabal index 12f69b8..b591cb9 100644 --- a/domaindriven-effectful-examples/domaindriven-effectful-examples.cabal +++ b/domaindriven-examples/domaindriven-examples.cabal @@ -1,9 +1,9 @@ cabal-version: 3.12 -name: domaindriven-effectful-examples +name: domaindriven-examples version: 0.5.0 -synopsis: Examples for domaindriven-effectful -description: Examples demonstrating the Effectful-based domaindriven library +synopsis: Examples for domaindriven +description: Examples demonstrating the domaindriven library category: Web homepage: https://github.com/tommyengstrom/domaindriven#readme bug-reports: https://github.com/tommyengstrom/domaindriven/issues @@ -85,7 +85,7 @@ executable postgres-example aeson , base , domaindriven-core - , domaindriven-effectful + , domaindriven , effectful , effectful-core , effectful-plugin @@ -103,7 +103,7 @@ executable simple-example aeson , base , domaindriven-core - , domaindriven-effectful + , domaindriven , effectful , effectful-core , effectful-plugin @@ -122,7 +122,7 @@ executable fieldname-as-path-example aeson , base , domaindriven-core - , domaindriven-effectful + , domaindriven , effectful , effectful-core , effectful-plugin diff --git a/domaindriven-effectful-examples/fieldname-as-path/Main.hs b/domaindriven-examples/fieldname-as-path/Main.hs similarity index 99% rename from domaindriven-effectful-examples/fieldname-as-path/Main.hs rename to domaindriven-examples/fieldname-as-path/Main.hs index 4727ea5..1c84121 100644 --- a/domaindriven-effectful-examples/fieldname-as-path/Main.hs +++ b/domaindriven-examples/fieldname-as-path/Main.hs @@ -12,7 +12,7 @@ module Main where import Control.Monad (when) import Data.Aeson (FromJSON, ToJSON) -import DomainDriven.Effectful +import DomainDriven import DomainDriven.FieldNameAsPath import DomainDriven.Persistance.ForgetfulInMemory (ForgetfulInMemory, createForgetful) import Effectful hiding ((:>)) diff --git a/domaindriven-effectful-examples/intro.txt b/domaindriven-examples/intro.txt similarity index 100% rename from domaindriven-effectful-examples/intro.txt rename to domaindriven-examples/intro.txt diff --git a/domaindriven-effectful-examples/postgres/Event/V1.hs b/domaindriven-examples/postgres/Event/V1.hs similarity index 100% rename from domaindriven-effectful-examples/postgres/Event/V1.hs rename to domaindriven-examples/postgres/Event/V1.hs diff --git a/domaindriven-effectful-examples/postgres/Event/V2.hs b/domaindriven-examples/postgres/Event/V2.hs similarity index 100% rename from domaindriven-effectful-examples/postgres/Event/V2.hs rename to domaindriven-examples/postgres/Event/V2.hs diff --git a/domaindriven-effectful-examples/postgres/EventMigration.hs b/domaindriven-examples/postgres/EventMigration.hs similarity index 100% rename from domaindriven-effectful-examples/postgres/EventMigration.hs rename to domaindriven-examples/postgres/EventMigration.hs diff --git a/domaindriven-effectful-examples/postgres/Main.hs b/domaindriven-examples/postgres/Main.hs similarity index 99% rename from domaindriven-effectful-examples/postgres/Main.hs rename to domaindriven-examples/postgres/Main.hs index 7163ce4..6fd31c5 100644 --- a/domaindriven-effectful-examples/postgres/Main.hs +++ b/domaindriven-examples/postgres/Main.hs @@ -9,7 +9,7 @@ module Main where import Control.Monad (when) import Database.PostgreSQL.Simple (connectPostgreSQL) -import DomainDriven.Effectful +import DomainDriven import DomainDriven.Persistance.Postgres (PostgresEvent, postgresWriteModel, simplePool) import Effectful hiding ((:>)) import Effectful qualified diff --git a/domaindriven-effectful-examples/simple/Main.hs b/domaindriven-examples/simple/Main.hs similarity index 99% rename from domaindriven-effectful-examples/simple/Main.hs rename to domaindriven-examples/simple/Main.hs index 0d6e4b7..5579296 100644 --- a/domaindriven-effectful-examples/simple/Main.hs +++ b/domaindriven-examples/simple/Main.hs @@ -12,7 +12,7 @@ import Control.Monad (when) import Data.Aeson (FromJSON, ToJSON) import Data.Time (UTCTime) import Data.UUID (UUID) -import DomainDriven.Effectful +import DomainDriven import DomainDriven.Persistance.ForgetfulInMemory (ForgetfulInMemory, createForgetful) import Effectful hiding ((:>)) import Effectful qualified diff --git a/domaindriven-effectful/README.md b/domaindriven/README.md similarity index 100% rename from domaindriven-effectful/README.md rename to domaindriven/README.md diff --git a/domaindriven-effectful/domaindriven-effectful.cabal b/domaindriven/domaindriven.cabal similarity index 88% rename from domaindriven-effectful/domaindriven-effectful.cabal rename to domaindriven/domaindriven.cabal index 706413c..fb5dc53 100644 --- a/domaindriven-effectful/domaindriven-effectful.cabal +++ b/domaindriven/domaindriven.cabal @@ -1,5 +1,5 @@ cabal-version: 3.12 -name: domaindriven-effectful +name: domaindriven version: 0.5.0 synopsis: Batteries included event sourcing and CQRS description: Please see the README on GitHub at @@ -73,11 +73,11 @@ common shared_opts library import: shared_opts exposed-modules: - DomainDriven.Effectful - DomainDriven.Effectful.Aggregate - DomainDriven.Effectful.Domain - DomainDriven.Effectful.Interpreter - DomainDriven.Effectful.Projection + DomainDriven + DomainDriven.Aggregate + DomainDriven.Domain + DomainDriven.Interpreter + DomainDriven.Projection DomainDriven.FieldNameAsPath Servant.Auth.Internal.ThrowAll.SOP hs-source-dirs: @@ -97,7 +97,7 @@ library , servant-server , text -test-suite domaindriven-effectful-test +test-suite domaindriven-test import: shared_opts type: exitcode-stdio-1.0 main-is: Spec.hs @@ -108,13 +108,13 @@ test-suite domaindriven-effectful-test build-tool-depends: hspec-discover:hspec-discover other-modules: - DomainDriven.Effectful.InMemorySpec + DomainDriven.InMemorySpec hs-source-dirs: test build-depends: base , domaindriven-core - , domaindriven-effectful + , domaindriven , effectful-core , effectful-plugin , hspec diff --git a/domaindriven/src/DomainDriven.hs b/domaindriven/src/DomainDriven.hs new file mode 100644 index 0000000..50b7120 --- /dev/null +++ b/domaindriven/src/DomainDriven.hs @@ -0,0 +1,14 @@ +module DomainDriven + ( -- * Domain configuration (re-exported) + module DomainDriven.Domain + + -- * Effects and helpers + , module X + ) +where + +import DomainDriven.Aggregate as X +import DomainDriven.Domain +import DomainDriven.Interpreter as X +import DomainDriven.Projection as X +import DomainDriven.Persistance.Class as X (Indexed (..), NoIndex (..), Stored (..)) diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs b/domaindriven/src/DomainDriven/Aggregate.hs similarity index 92% rename from domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs rename to domaindriven/src/DomainDriven/Aggregate.hs index 36975f0..2f4e35f 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Aggregate.hs +++ b/domaindriven/src/DomainDriven/Aggregate.hs @@ -1,11 +1,11 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TemplateHaskell #-} -module DomainDriven.Effectful.Aggregate where +module DomainDriven.Aggregate where import Data.Kind (Type) import Data.Type.Equality -import DomainDriven.Effectful.Domain +import DomainDriven.Domain import DomainDriven.Persistance.Class (NoIndex (..)) import Effectful import Effectful.TH diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Domain.hs b/domaindriven/src/DomainDriven/Domain.hs similarity index 86% rename from domaindriven-effectful/src/DomainDriven/Effectful/Domain.hs rename to domaindriven/src/DomainDriven/Domain.hs index b1c0b5c..1cf305b 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Domain.hs +++ b/domaindriven/src/DomainDriven/Domain.hs @@ -1,5 +1,5 @@ -module DomainDriven.Effectful.Domain - ( module DomainDriven.Effectful.Domain +module DomainDriven.Domain + ( module DomainDriven.Domain ) where import Data.Kind (Type) diff --git a/domaindriven-effectful/src/DomainDriven/FieldNameAsPath.hs b/domaindriven/src/DomainDriven/FieldNameAsPath.hs similarity index 100% rename from domaindriven-effectful/src/DomainDriven/FieldNameAsPath.hs rename to domaindriven/src/DomainDriven/FieldNameAsPath.hs diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter.hs b/domaindriven/src/DomainDriven/Interpreter.hs similarity index 90% rename from domaindriven-effectful/src/DomainDriven/Effectful/Interpreter.hs rename to domaindriven/src/DomainDriven/Interpreter.hs index 52cc433..c3cb1e3 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Interpreter.hs +++ b/domaindriven/src/DomainDriven/Interpreter.hs @@ -1,11 +1,11 @@ -module DomainDriven.Effectful.Interpreter +module DomainDriven.Interpreter ( runAggregate , runProjection ) where -import DomainDriven.Effectful.Aggregate -import DomainDriven.Effectful.Domain -import DomainDriven.Effectful.Projection +import DomainDriven.Aggregate +import DomainDriven.Domain +import DomainDriven.Projection import DomainDriven.Persistance.Class (ReadModel, WriteModel) import DomainDriven.Persistance.Class qualified as P import Effectful diff --git a/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs b/domaindriven/src/DomainDriven/Projection.hs similarity index 93% rename from domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs rename to domaindriven/src/DomainDriven/Projection.hs index e0cf8d7..81fd1a4 100644 --- a/domaindriven-effectful/src/DomainDriven/Effectful/Projection.hs +++ b/domaindriven/src/DomainDriven/Projection.hs @@ -4,10 +4,10 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module DomainDriven.Effectful.Projection where +module DomainDriven.Projection where import Data.Type.Equality -import DomainDriven.Effectful.Domain +import DomainDriven.Domain import DomainDriven.Persistance.Class (NoIndex (..), Stored) import Effectful import Effectful.TH diff --git a/domaindriven-effectful/src/Servant/Auth/Internal/ThrowAll/SOP.hs b/domaindriven/src/Servant/Auth/Internal/ThrowAll/SOP.hs similarity index 100% rename from domaindriven-effectful/src/Servant/Auth/Internal/ThrowAll/SOP.hs rename to domaindriven/src/Servant/Auth/Internal/ThrowAll/SOP.hs diff --git a/domaindriven-effectful/test/DomainDriven/Effectful/InMemorySpec.hs b/domaindriven/test/DomainDriven/InMemorySpec.hs similarity index 96% rename from domaindriven-effectful/test/DomainDriven/Effectful/InMemorySpec.hs rename to domaindriven/test/DomainDriven/InMemorySpec.hs index 6f90840..efa15a5 100644 --- a/domaindriven-effectful/test/DomainDriven/Effectful/InMemorySpec.hs +++ b/domaindriven/test/DomainDriven/InMemorySpec.hs @@ -1,9 +1,9 @@ -module DomainDriven.Effectful.InMemorySpec (spec) where +module DomainDriven.InMemorySpec (spec) where -import DomainDriven.Effectful.Aggregate -import DomainDriven.Effectful.Domain -import DomainDriven.Effectful.Interpreter -import DomainDriven.Effectful.Projection +import DomainDriven.Aggregate +import DomainDriven.Domain +import DomainDriven.Interpreter +import DomainDriven.Projection import DomainDriven.Persistance.Class (Indexed (..), NoIndex (..), Stored (..)) import DomainDriven.Persistance.ForgetfulInMemory import Effectful diff --git a/domaindriven-effectful/test/Spec.hs b/domaindriven/test/Spec.hs similarity index 100% rename from domaindriven-effectful/test/Spec.hs rename to domaindriven/test/Spec.hs diff --git a/flake.nix b/flake.nix index c2ae8bd..7866e38 100644 --- a/flake.nix +++ b/flake.nix @@ -36,6 +36,7 @@ export PKG_CONFIG_PATH="${pkgs.xz.dev}/lib/pkgconfig:${pkgs.zlib.dev}/lib/pkgconfig:$PKG_CONFIG_PATH" export LIBRARY_PATH="${pkgs.xz.out}/lib:${pkgs.zlib.out}/lib:${pkgs.gmp.out}/lib:${pkgs.libpq.out}/lib:$LIBRARY_PATH" export LD_LIBRARY_PATH="${pkgs.xz.out}/lib:${pkgs.zlib.out}/lib:${pkgs.gmp.out}/lib:${pkgs.libpq.out}/lib:$LD_LIBRARY_PATH" + exec ${pkgs.fish}/bin/fish ''; }; }); diff --git a/run-ghcid.sh b/run-ghcid.sh index 7944377..cb849b7 100755 --- a/run-ghcid.sh +++ b/run-ghcid.sh @@ -25,6 +25,6 @@ ghcid \ --command "cabal v2-repl --enable-multi-repl $components" \ --restart "cabal.project" \ --restart "domaindriven-core/domaindriven-core.cabal" \ - --restart "domaindriven-effectful/domaindriven-effectful.cabal" \ - --restart "domaindriven-effectful-examples/domaindriven-effectful-examples.cabal" \ + --restart "domaindriven/domaindriven.cabal" \ + --restart "domaindriven-examples/domaindriven-examples.cabal" \ -o $LOG_FILE From ef8c48a58db2428cc0119befac9083e434a989eb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Wed, 25 Feb 2026 15:47:13 +0100 Subject: [PATCH 49/50] make shape-coerce a separate package --- cabal.project | 1 + domaindriven-core/domaindriven-core.cabal | 1 - .../domaindriven-examples.cabal | 1 + shape-coerce/LICENSE | 30 +++++++ shape-coerce/shape-coerce.cabal | 81 +++++++++++++++++++ .../src/Data/ShapeCoerce.hs | 0 6 files changed, 113 insertions(+), 1 deletion(-) create mode 100644 shape-coerce/LICENSE create mode 100644 shape-coerce/shape-coerce.cabal rename {domaindriven-core => shape-coerce}/src/Data/ShapeCoerce.hs (100%) diff --git a/cabal.project b/cabal.project index 8f9bad0..1849468 100644 --- a/cabal.project +++ b/cabal.project @@ -1,4 +1,5 @@ packages: + shape-coerce/ domaindriven-core/ domaindriven/ domaindriven-examples/ diff --git a/domaindriven-core/domaindriven-core.cabal b/domaindriven-core/domaindriven-core.cabal index ac50c56..0d04d42 100644 --- a/domaindriven-core/domaindriven-core.cabal +++ b/domaindriven-core/domaindriven-core.cabal @@ -74,7 +74,6 @@ common default_opts library import: default_opts exposed-modules: - Data.ShapeCoerce DomainDriven.Persistance.Class DomainDriven.Persistance.ForgetfulInMemory DomainDriven.Persistance.Postgres diff --git a/domaindriven-examples/domaindriven-examples.cabal b/domaindriven-examples/domaindriven-examples.cabal index b591cb9..1a29579 100644 --- a/domaindriven-examples/domaindriven-examples.cabal +++ b/domaindriven-examples/domaindriven-examples.cabal @@ -90,6 +90,7 @@ executable postgres-example , effectful-core , effectful-plugin , postgresql-simple + , shape-coerce , servant , servant-server , warp diff --git a/shape-coerce/LICENSE b/shape-coerce/LICENSE new file mode 100644 index 0000000..3d5933c --- /dev/null +++ b/shape-coerce/LICENSE @@ -0,0 +1,30 @@ +Copyright Tommy Engström (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Tommy Engström nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/shape-coerce/shape-coerce.cabal b/shape-coerce/shape-coerce.cabal new file mode 100644 index 0000000..4f1b11e --- /dev/null +++ b/shape-coerce/shape-coerce.cabal @@ -0,0 +1,81 @@ +cabal-version: 3.12 + +name: shape-coerce +version: 0.5.0 +synopsis: Generic coercion between types with the same shape +description: A general-purpose generic coercion utility that allows converting between + types that share the same structure (constructors, fields) but differ in + module or package origin. +category: Generics +homepage: https://github.com/tommyengstrom/domaindriven#readme +bug-reports: https://github.com/tommyengstrom/domaindriven/issues +author: Tommy Engström +maintainer: tommy@succinct.se +copyright: 2025 Tommy Engström +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple + +source-repository head + type: git + location: https://github.com/tommyengstrom/domaindriven + +common default_opts + default-language: Haskell2010 + default-extensions: + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedLabels + AllowAmbiguousTypes + BlockArguments + OverloadedStrings + PolyKinds + RankNTypes + ScopedTypeVariables + StandaloneDeriving + StrictData + TupleSections + TypeApplications + TypeFamilyDependencies + TypeOperators + TypeSynonymInstances + ViewPatterns + ghc-options: + -Wall + -Werror + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wpartial-fields + -Wredundant-constraints + -Wincomplete-patterns + -Wunused-packages + -Wno-missing-import-lists + +library + import: default_opts + exposed-modules: + Data.ShapeCoerce + hs-source-dirs: + src + build-depends: + base + , containers diff --git a/domaindriven-core/src/Data/ShapeCoerce.hs b/shape-coerce/src/Data/ShapeCoerce.hs similarity index 100% rename from domaindriven-core/src/Data/ShapeCoerce.hs rename to shape-coerce/src/Data/ShapeCoerce.hs From 4eb8793cef00f86f21c70aecd3b0036ea123965f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tommy=20Engstr=C3=B6m?= Date: Mon, 2 Mar 2026 07:36:43 +0100 Subject: [PATCH 50/50] create initial domaindriven agent skill --- .claude-plugin/marketplace.json | 13 ++ .claude-plugin/plugin.json | 11 ++ skills/domaindriven/SKILL.md | 172 +++++++++++++++++++++++++++ skills/domaindriven/project-setup.md | 126 ++++++++++++++++++++ 4 files changed, 322 insertions(+) create mode 100644 .claude-plugin/marketplace.json create mode 100644 .claude-plugin/plugin.json create mode 100644 skills/domaindriven/SKILL.md create mode 100644 skills/domaindriven/project-setup.md diff --git a/.claude-plugin/marketplace.json b/.claude-plugin/marketplace.json new file mode 100644 index 0000000..0a6f8d1 --- /dev/null +++ b/.claude-plugin/marketplace.json @@ -0,0 +1,13 @@ +{ + "name": "domaindriven", + "owner": { + "name": "Tommy Engström" + }, + "plugins": [ + { + "name": "domaindriven", + "source": ".", + "description": "Claude skill for the domaindriven Haskell event sourcing and CQRS library" + } + ] +} diff --git a/.claude-plugin/plugin.json b/.claude-plugin/plugin.json new file mode 100644 index 0000000..05bab59 --- /dev/null +++ b/.claude-plugin/plugin.json @@ -0,0 +1,11 @@ +{ + "name": "domaindriven", + "description": "Claude skill for the domaindriven Haskell event sourcing and CQRS library", + "version": "0.1.0", + "author": { + "name": "Tommy Engström" + }, + "repository": "https://github.com/tommyengstrom/domaindriven", + "license": "BSD-3-Clause", + "keywords": ["haskell", "event-sourcing", "cqrs", "domain-driven-design", "effectful", "servant"] +} diff --git a/skills/domaindriven/SKILL.md b/skills/domaindriven/SKILL.md new file mode 100644 index 0000000..933e6bc --- /dev/null +++ b/skills/domaindriven/SKILL.md @@ -0,0 +1,172 @@ +--- +name: domaindriven +description: Help users build applications with the domaindriven Haskell event sourcing library +--- + +You are an expert in the `domaindriven` Haskell library. Follow these patterns exactly. + +## Architecture + +Synchronous event sourcing with Effectful effects and Servant APIs. + +Dependencies: `domaindriven-core` (persistence backends), `domaindriven` (Effectful API layer), `shape-coerce` (event migration). + +## Core Pattern + +```haskell +-- 1. Domain triple +type MyDomain = Domain MyModel MyEvent NoIndex + +-- 2. Events (must derive Generic, ToJSON, FromJSON) +data MyEvent = ThingHappened | ValueSet Int + +-- 3. Apply events to build state +applyEvent :: MyModel -> Stored MyEvent -> MyModel +applyEvent m (Stored evt _ _) = case evt of + ThingHappened -> m { flag = True } + ValueSet n -> m { value = n } + +-- 4. Create backend +-- Testing: +backend <- createForgetful applyEvent initialModel +-- Production: +pool <- simplePool' connectInfo +backend <- postgresWriteModel pool eventTable applyEvent initialModel + +-- 5. Handlers use Aggregate (write) and Projection (read) effects +myHandler + :: (Aggregate MyDomain :> es, Projection MyDomain :> es, Error ServerError :> es) + => MyAPI (AsServerT (Eff es)) +myHandler = MyAPI + { getState = getModel -- Projection: read current state + , doThing = runTransaction \model -> + pure (const (), [ThingHappened]) -- (extractor from updated model, events) + } + +-- 6. Wire effect stack +runEffects :: Eff '[Projection MyDomain, Aggregate MyDomain, Error ServerError, IOE] a -> Handler a +runEffects m = do + a <- liftIO . runEff . runErrorNoCallStack @ServerError + . runAggregate backend . runProjection backend $ m + either throwError pure a +``` + +## Key Types + +```haskell +data Stored a = Stored + { storedEvent :: a + , storedTimestamp :: UTCTime + , storedUUID :: UUID + } + +data Domain (model :: Type) (event :: Type) (index :: Type) = Domain + +data NoIndex = NoIndex +newtype Indexed = Indexed Text + +data Aggregate (domain :: Type) :: Effect where + RunTransactionI + :: DomainIndex domain + -> (DomainModel domain -> Eff es (DomainModel domain -> a, [DomainEvent domain])) + -> Aggregate domain (Eff es) a + +data Projection domain :: Effect where + GetModelI :: DomainIndex domain -> Projection domain m (DomainModel domain) + GetEventListI :: DomainIndex domain -> Projection domain m [Stored (DomainEvent domain)] +``` + +## `runTransaction` Return Convention + +The callback returns `(Model -> a, [Event])`: +- First element extracts return value from the *updated* model (after events applied) +- `const ()` when nothing to return, `id` to return whole model, `(.someField)` for a field + +## Indexed Aggregates + +Use `runTransactionI` and `getModelI` with an index: + +```haskell +type MyDomain = Domain MyModel MyEvent Indexed +increase :: Indexed -> Eff es Int +increase idx = runTransactionI idx \model -> pure ((.counter), [Increased]) +``` + +## Servant Integration + +`FieldNameAsPath` derives URL paths from record field names. Each field name becomes a path segment automatically: + +```haskell +data CounterAPI mode = CounterAPI + { get :: mode :- Get '[JSON] Int -- GET /get + , increase :: mode :- Post '[JSON] Int -- POST /increase + , decrease :: mode :- Post '[JSON] Int -- POST /decrease + } deriving Generic + +instance ApiTagFromLabel CounterAPI +``` + +Compare with standard Servant Generic where you must spell out paths in the type: + +```haskell +data CounterAPI mode = CounterAPI + { get :: mode :- Get '[JSON] Int -- GET / + , increase :: mode :- "increase" :> Post '[JSON] Int -- POST /increase + , decrease :: mode :- "decrease" :> Post '[JSON] Int -- POST /decrease + } deriving Generic +``` + +Serve with: + +```haskell +serve (Proxy @(FieldNameAsPathApi CounterAPI)) + $ hoistServer (Proxy @(FieldNameAsPathApi CounterAPI)) runEffects + $ FieldNameAsPathServer counterHandler +``` + +## Event Migration (Postgres) + +Use `shape-coerce` for migrations. Let the compiler guide you: + +1. First, try just `shapeCoerce`. If the old and new event types are structurally identical (same constructor names, same fields), it works automatically via Generics. + +2. If the types differ, the compiler will tell you exactly what doesn't match (constructor name mismatch, field mismatch, etc.). Write a manual `ShapeCoercible` instance for the cases it can't derive: + +```haskell +-- V1 +data CounterEvent = CounterIncreased | CounterDecreased + +-- V2: constructors changed, so automatic shapeCoerce fails at compile time. +-- Write the instance the compiler is asking for: +data CounterEvent = CounterIncreasedBy Int | CounterDecreasedBy Int + +instance ShapeCoercible V1.CounterEvent V2.CounterEvent where + shapeCoerce = \case + V1.CounterIncreased -> V2.CounterIncreasedBy 1 + V1.CounterDecreased -> V2.CounterDecreasedBy 1 +``` + +3. Wire it into the migration. `Stored` is a `Functor` so `shapeCoerce` on `Stored a -> Stored b` works automatically once the inner event type has an instance: + +```haskell +eventTable :: EventTable +eventTable = MigrateUsing myMigration $ InitialVersion "my_events" +-- Creates my_events_v1 (initial), my_events_v2 (after migration) + +myMigration :: EventMigration +myMigration prev next conn = migrate1to1 @NoIndex conn prev next shapeCoerce +``` + +For multi-package project setup with compile-time migration safety, see [project-setup.md](project-setup.md). + +## Imports + +```haskell +import DomainDriven -- re-exports everything from the effectful layer +-- Or individually: +import DomainDriven.Persistance.Class -- Stored, ReadModel, WriteModel, NoIndex, Indexed +import DomainDriven.Persistance.ForgetfulInMemory -- createForgetful +import DomainDriven.Persistance.Postgres -- PostgresEvent, postgresWriteModel, simplePool +import DomainDriven.Persistance.Postgres.Migration -- migrate1to1, migrate1toMany +import Data.ShapeCoerce -- shapeCoerce, ShapeCoercible +``` diff --git a/skills/domaindriven/project-setup.md b/skills/domaindriven/project-setup.md new file mode 100644 index 0000000..f3a6d5b --- /dev/null +++ b/skills/domaindriven/project-setup.md @@ -0,0 +1,126 @@ +# Project Setup: 3-Package Event Migration Pattern + +Split your project into three packages for safe, incremental event schema evolution with compile-time guarantees. + +## Package Structure + +``` +my-project/ +├── lib/my-project-events/ # Current event types +│ └── src/MyProject/Event.hs +├── lib/my-project-migrations/ # Versioned snapshots + migration logic +│ └── src/ +│ ├── Event49/Event.hs # Snapshot of events at version 49 +│ ├── Event50/Event.hs # Snapshot of events at version 50 +│ ├── Migration/V50.hs # Migration from 49 → 50 +│ └── ... +└── services/my-project/ # Main service + └── src/MyProject/Runner.hs # Chains migrations, verifies consistency +``` + +### `-events` +Canonical, current event types. This is the only package you edit when changing events. + +### `-migrations` +Two kinds of modules: +- **Event snapshots** (`EventN.*`): Frozen copies of `-events` at version N. Created by copying all modules from `-events` into an `EventN.*` namespace. +- **Migration modules** (`Migration.VN`): Convert `Event(N-1)` → `EventN` using `shapeCoerce`. + +### `` (main service) +Contains `Runner.hs` that chains all migrations and uses `ensureMigrationIsUpToDate` to verify the latest snapshot matches current events. + +## Creating a New Event Snapshot + +When you need to migrate (version N-1 → N): + +1. Copy all modules from `-events/src/` into `-migrations/src/EventN/` +2. Rename the module declarations (e.g. `MyProject.Event.Types` → `EventN.Event.Types`) +3. Update internal imports within the snapshot to use `EventN.*` +4. Add the new `EventN.*` modules to `-migrations.cabal` + +## Writing a Migration Module + +```haskell +module Migration.VN where + +import EventPrev.Event qualified as Old -- previous snapshot +import EventN.Event qualified as New -- new snapshot +import Data.ShapeCoerce + +fixEvent :: ShapeCoercible (Old.MyEvent) (New.MyEvent) + => Stored (Old.MyEvent) -> Stored (New.MyEvent) +fixEvent = fmap shapeCoerce + +-- If types changed structurally, write manual instances: +instance ShapeCoercible Old.SomeType New.SomeType where + shapeCoerce old = New.SomeType + { field1 = shapeCoerce (Old.field1 old) + , newField = defaultValue -- added field + } + +myMigration :: PreviousEventTableName -> EventTableName -> Connection -> IO () +myMigration prev next conn = migrate1to1 @NoIndex conn prev next fixEvent +``` + +The compiler guides you: try `shapeCoerce` first. If old and new types are structurally identical, it works automatically. If not, the compiler error tells you exactly which types differ and need a manual `ShapeCoercible` instance. + +## Chaining Migrations in Runner.hs + +```haskell +eventTable :: EventTable +eventTable = + ensureMigrationIsUpToDate + $ MigrateUsing migrationV50 + $ MigrateUsing migrationV49 + $ MigrateUsing discardedMigration + $ MigrateUsing discardedMigration + -- ... older discarded versions ... + $ InitialVersion "events" +``` + +Each `MigrateUsing` wraps one migration step. The chain reads newest-first, oldest-last, with `InitialVersion` at the bottom. + +## `ensureMigrationIsUpToDate` + +A zero-cost identity function that provides compile-time verification: + +```haskell +ensureMigrationIsUpToDate + :: ShapeIsomorphic MyEvent Latest.MyEvent + => x -> x +ensureMigrationIsUpToDate = id +``` + +`ShapeIsomorphic a b` means `(ShapeCoercible a b, ShapeCoercible b a)` — the types must be structurally identical in both directions. This ensures: +- If you change events in `-events` without creating a new snapshot, **compilation fails** +- If you create a snapshot but forget to update the `Latest` import in Runner.hs, **compilation fails** + +The `Latest` import aliases the newest snapshot: + +```haskell +import EventN.Event qualified as Latest +``` + +## `discardedMigration` + +Once all database instances have migrated past a version, replace its migration with `discardedMigration` to improve compile times: + +```haskell +-- | A migration that is no longer kept. +-- Once all instances have migrated past this version, the migration code +-- can be discarded. This improves compile speed. +discardedMigration :: PreviousEventTableName -> EventTableName -> Connection -> IO () +discardedMigration _ etName conn = void $ createEventTable' conn etName +``` + +You can also remove the corresponding `EventN.*` snapshot modules from the migrations package. + +## Workflow Summary + +1. **Change events** in `-events` +2. **Snapshot**: copy modules into `-migrations` as `EventN.*` +3. **Write migration**: create `Migration.VN` importing old as `Old`, new as `New` +4. **Chain**: add `MigrateUsing migrationVN $` to the top of the chain in Runner.hs +5. **Update Latest**: change the `Latest` import to `EventN` +6. **Compile**: `ensureMigrationIsUpToDate` verifies everything is consistent +7. **Over time**: replace old migrations with `discardedMigration` and remove their snapshots