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/.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/.claude/settings.local.json b/.claude/settings.local.json new file mode 100644 index 0000000..0dbb16d --- /dev/null +++ b/.claude/settings.local.json @@ -0,0 +1,12 @@ +{ + "permissions": { + "allow": [ + "WebFetch(domain:hackage.haskell.org)", + "WebFetch(domain:hackage-content.haskell.org)", + "WebFetch(domain:github.com)", + "WebFetch(domain:www.stackage.org)", + "Bash(cabal:*)" + ], + "deny": [] + } +} diff --git a/.github/workflows/main.yaml b/.github/workflows/main.yaml index ff1b8de..713aab2 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,30 @@ 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 + 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 + ~/.cabal/packages + dist-newstyle + key: ${{ runner.os }}-cabal-${{ hashFiles('cabal.project', '**/*.cabal') }} + restore-keys: | + ${{ runner.os }}-cabal- + + - name: Update package index + run: nix develop --command cabal update + - name: Build + run: nix develop --command cabal build all + + - name: Run tests + run: nix develop --command cabal test all diff --git a/.gitignore b/.gitignore index 2e01463..9a05b39 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,5 @@ stack.yaml.lock hie.yaml dist-newstyle/ .vscode +.repro +ai_docs diff --git a/CLAUDE.md b/CLAUDE.md new file mode 100644 index 0000000..be0aedb --- /dev/null +++ b/CLAUDE.md @@ -0,0 +1,53 @@ +# CLAUDE.md + +This file provides guidance to Claude Code (claude.ai/code) when working with code in this repository. + +## Build Commands + +- **Build all packages**: `cabal build all` +- **Build specific package**: `cabal build domaindriven` +- **Run tests**: `cabal test all` +- **Run specific test**: `cabal test domaindriven` +- **Clean build**: `cabal 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**: 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/` + +### 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 .cabal files) +- Strict warning settings (`-Wall -Werror`) - fix all warnings before committing +- 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 20ec261..61c6dca 100644 --- a/README.md +++ b/README.md @@ -1,8 +1,11 @@ # DomainDriven -DomainDriven is a batteries included synchronous event sourcing and CQRS library. It is split into two parts: +DomainDriven is a batteries included synchronous event sourcing and CQRS library. It is split into the following packages: -- [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-core](domaindriven-core) - Core persistence model with PostgreSQL and in-memory backends. +- [domaindriven](domaindriven) - Effectful-based API layer with `Aggregate` and `Projection` effects, plus Servant integration. +- [domaindriven-examples](domaindriven-examples) - Example applications demonstrating usage. +## Design idea +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/cabal.project b/cabal.project new file mode 100644 index 0000000..1849468 --- /dev/null +++ b/cabal.project @@ -0,0 +1,10 @@ +packages: + shape-coerce/ + domaindriven-core/ + domaindriven/ + domaindriven-examples/ + +-- Use Stackage LTS 24.2 as the main package source +import: https://www.stackage.org/lts-24.31/cabal.config + +with-compiler: ghc-9.10.3 diff --git a/domaindriven-core/domaindriven-core.cabal b/domaindriven-core/domaindriven-core.cabal index 85c00bc..0d04d42 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.36.0. --- --- 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,18 +21,8 @@ source-repository head type: git location: https://github.com/tommyengstrom/domaindriven -library - exposed-modules: - 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 @@ -58,6 +44,8 @@ library NamedFieldPuns NoImplicitPrelude OverloadedLabels + AllowAmbiguousTypes + BlockArguments OverloadedStrings PolyKinds RankNTypes @@ -70,88 +58,75 @@ 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-patterns + -Wunused-packages + -Wno-missing-import-lists + +library + import: default_opts + exposed-modules: + 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 >=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 + , base + , containers + , deepseq + , exceptions + , generic-lens + , hashable + , 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 + , text + , time + , unliftio + , unordered-containers + , uuid default-language: Haskell2010 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 - Paths_domaindriven_core + DomainDriven.Persistance.Postgres.TypesSpec 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 -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 - default-language: Haskell2010 + , hspec + , postgresql-simple + , streamly + , text + , time + , unliftio + , unliftio-pool + , uuid diff --git a/domaindriven-core/package.yaml b/domaindriven-core/package.yaml deleted file mode 100644 index bebfb02..0000000 --- a/domaindriven-core/package.yaml +++ /dev/null @@ -1,119 +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 >=2.0.3 && <2.2 -- base >=4.7 && <5 -- generic-lens >=2.2.1.0 && <2.3 -- microlens >=0.4.12.0 && <0.5 - - -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 -- -Wcompat -- -Widentities -- -Wincomplete-record-updates -- -Wincomplete-uni-patterns -- -Wpartial-fields -- -Wredundant-constraints -- -Wincomplete-record-updates -- -Wincomplete-patterns -- -Wunused-packages -- -Wall-missed-specialisations - -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 - - resource-pool - - uuid >=1.3.15 && <1.4 - - unordered-containers >=0.2.19.1 && <0.3 - - vector >=0.12.3.1 && <0.14 -tests: - domaindriven-core-test: - main: Spec.hs - source-dirs: - - test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -Wall - - -Wunused-packages - 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 diff --git a/domaindriven-core/src/DomainDriven/Persistance/Class.hs b/domaindriven-core/src/DomainDriven/Persistance/Class.hs index 008e09a..6707596 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Class.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Class.hs @@ -1,73 +1,63 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} - 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) import GHC.Stack import Streamly.Data.Stream.Prelude (Stream) +import System.IO (hPutStrLn) import System.Random import UnliftIO import Prelude +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)) - -type RunCmd model event m a = (model -> m (model -> a, [event])) -> m a + 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)) 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 + -> Index p -> Model p -> [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 . MonadUnliftIO m => p + -> Index 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 -runCmd - :: HasCallStack - => forall p m a - . (WriteModel p, MonadUnliftIO m) - => p - -> RunCmd (Model p) (Event p) m a -runCmd p cmd = withFrozenCallStack $ do - (model, events, returnFun) <- transactionalUpdate p cmd - _ <- async $ postUpdateHook p model events - 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. @@ -89,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/src/DomainDriven/Persistance/ForgetfulInMemory.hs b/domaindriven-core/src/DomainDriven/Persistance/ForgetfulInMemory.hs index 9f61be3..b00a10a 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/ForgetfulInMemory.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/ForgetfulInMemory.hs @@ -2,7 +2,11 @@ module DomainDriven.Persistance.ForgetfulInMemory where -import Data.List (foldl') +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 @@ -10,49 +14,56 @@ import UnliftIO 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 + :: 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 = 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.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres.hs index d952e83..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 @@ -16,5 +18,6 @@ import DomainDriven.Persistance.Postgres.Types as X , 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 5c6b35f..a1096e6 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Internal.hs @@ -5,10 +5,16 @@ 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 +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM +import Data.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 @@ -61,23 +67,28 @@ showOnlyCallSite stack = go (getCallStack stack) _ : xs -> go xs [] -> "" -data PostgresEvent model event = PostgresEvent +data PostgresEvent index model 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 index model event + -> index + -> model + -> [Stored event] + -> IO () , logger :: LogEntry -> IO () } deriving (Generic) -data PostgresEventTrans model event = PostgresEventTrans +data PostgresEventTrans index model 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,61 +97,68 @@ 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 +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 = withIOTrans pg getModel' + getModel pg index = liftIO $ 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 +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 - :: (FromJSON e, WriteModel (PostgresEventTrans m e)) - => PostgresEventTrans m e - -> IO () +createEventTable :: PostgresEventTrans index model 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 " + <> quoteIdent 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 \"" - <> 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\ - \);" + "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 = @@ -150,28 +168,42 @@ 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 - => (FromJSON event, WriteModel (PostgresEventTrans model event)) => Pool Connection -> EventTableName -> (model -> Stored event -> model) -> model - -> IO (PostgresEvent model event) + -> IO (PostgresEvent index model event) postgresWriteModelNoMigration pool eventTable app' seed' = do pg <- createPostgresPersistance pool eventTable app' seed' withIOTrans pg createEventTable @@ -184,7 +216,7 @@ postgresWriteModel -> EventTable -> (model -> Stored event -> model) -> model - -> IO (PostgresEvent model 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 @@ -212,7 +244,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 @@ -230,16 +262,16 @@ runMigrations logger trans et = do void $ createEventTable' conn tableName createPostgresPersistance - :: forall event model + :: forall event index model . Pool Connection -> EventTableName -> (model -> Stored event -> model) -- ^ Apply event -> model -- ^ Initial model - -> IO (PostgresEvent model event) + -> IO (PostgresEvent index model event) createPostgresPersistance pool eventTable app' seed' = do - ref <- newIORef $ NumberedModel seed' 0 + ref <- newIORef HM.empty pure $ PostgresEvent { connectionPool = pool @@ -248,7 +280,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 +289,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" + "select id, event_number,timestamp,event from " + <> quoteIdent eventTable + <> " where index = " + <> toQuery index + <> " order by event_number" queryEventsAfter :: FromJSON a @@ -280,9 +316,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" ) @@ -290,21 +326,30 @@ 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 > " + "select id, event_number,timestamp,event from " + <> quoteIdent eventTable + <> " where index = " + <> toQuery index + <> " and event_number > " <> 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" + "select id, event_number,timestamp,event from " + <> quoteIdent eventTable + <> " where index = " + <> toQuery index + <> " order by event_number" headMay :: [a] -> Maybe a headMay = \case @@ -317,57 +362,97 @@ 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 +-- :: 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 (?, ?, ?)" + ( "insert into " + <> quoteIdent eventTable + <> " (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 " + <> quoteIdent eventTable + ) getEventStream' - :: FromJSON event => PostgresEventTrans model event -> Stream IO (Stored event) -getEventStream' pgt = + :: ( FromJSON event + , IsPgIndex index + ) + => PostgresEventTrans index model 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 index model event . HasCallStack => (Stream.MonadAsync m, MonadCatch m) - => PostgresEvent model event - -> (PostgresEventTrans model 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 event) + startTrans :: m (PostgresEventTrans index model event) startTrans = liftIO $ do (connR, localPool) <- takeResource (connectionPool pg) t0 <- getCurrentTime @@ -383,7 +468,7 @@ withStreamReadTransaction pg = Stream.bracket startTrans rollbackTrans , logger = pg ^. field @"logger" } - rollbackTrans :: PostgresEventTrans model 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" @@ -403,10 +488,10 @@ withStreamReadTransaction pg = Stream.bracket startTrans rollbackTrans destroyResource (connectionPool pg) localPool conn withIOTrans - :: forall a model event + :: forall a index model event . HasCallStack - => PostgresEvent model event - -> (PostgresEventTrans model event -> IO a) + => PostgresEvent index model event + -> (PostgresEventTrans index model event -> IO a) -> IO a withIOTrans pg f = do transactionCompleted <- newIORef False @@ -422,7 +507,7 @@ withIOTrans pg f = do writeIORef transactionCompleted True pure a where - cleanup :: IORef Bool -> PostgresEventTrans model 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 @@ -445,7 +530,7 @@ withIOTrans pg f = do prepareTransaction :: Pool.Resource Connection -> LocalPool Connection - -> IO (PostgresEventTrans model event) + -> IO (PostgresEventTrans index model event) prepareTransaction connR localPool = do t0 <- getCurrentTime PG.begin $ Pool.resource connR @@ -484,35 +569,54 @@ 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 index m + . (IsPgIndex index, FromJSON e) + => PostgresEventTrans index m e + -> index + -> 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 i m e + . (IsPgIndex i, FromJSON e) + => PostgresEventTrans i m e + -> i -> IO (m, EventNumber) -refreshModel pgt = withExclusiveLock pgt $ do +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 <- readIORef (pgt ^. field @"modelIORef") + NumberedModel model lastEventNo <- getCurrentState pgt index let eventStream = 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) = NumberedModel ((pgt ^. field @"app") m ev) evNumber - NumberedModel newModel lastNewEventNo <- + newNumberedModel@(NumberedModel newModel lastNewEventNo) <- Stream.fold ( Fold.foldl' applyModel @@ -520,44 +624,56 @@ 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 () -exclusiveLock (OngoingTransaction connR _ _) etName = +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 $ - execute_ (Pool.resource connR) ("lock \"" <> fromString etName <> "\" in exclusive mode") + ( query + (Pool.resource connR) + "SELECT pg_advisory_xact_lock(?)" + (Only (fromIntegral (hash index) :: Int64)) + :: IO [Only ()] + ) -withExclusiveLock :: HasCallStack => PostgresEventTrans m e -> IO a -> IO a -withExclusiveLock pgt a = do +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 - exclusiveLock (pgt ^. field' @"transaction") (pgt ^. field @"eventTableName") r <- a t1 <- getCurrentTime pgt ^. field' @"logger" $ 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 i m e) where + postUpdateHook pg i m e = liftIO $ (pg ^. field @"updateHook") pg i m e - transactionalUpdate pg cmd = withRunInIO $ \runInIO -> - withIOTrans pg $ \pgt -> withExclusiveLock pgt $ do - m <- getModel' pgt + transactionalUpdate pg index cmd = withRunInIO $ \runInIO -> + withIOTrans pg $ \pgt -> withExclusiveLock pgt index $ do + m <- getModel' pgt index (returnFun, evs) <- runInIO $ cmd m - NumberedModel m' _ <- readIORef (pg ^. field @"modelIORef") 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 (pgt ^. field @"transaction" . field @"connectionResource" . field @"resource") (pg ^. field @"eventTableName") + index 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-core/src/DomainDriven/Persistance/Postgres/Migration.hs b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Migration.hs index b069b8a..c7f0fc6 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Migration.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Migration.hs @@ -1,15 +1,14 @@ +{-# 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 - , 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 @@ -21,36 +20,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 +61,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 +83,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 +109,36 @@ 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 (?, ?, ?)" + ( "insert into " + <> quoteIdent tName + <> " (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 " <> 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 aca1079..bb58671 100644 --- a/domaindriven-core/src/DomainDriven/Persistance/Postgres/Types.hs +++ b/domaindriven-core/src/DomainDriven/Persistance/Postgres/Types.hs @@ -1,9 +1,18 @@ -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 +import Data.Hashable (Hashable) import Data.Int 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,6 +23,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 @@ -25,6 +42,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-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 diff --git a/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs b/domaindriven-core/test/DomainDriven/Persistance/PostgresSpec.hs index 15804f0..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) @@ -12,6 +13,7 @@ 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) @@ -30,7 +32,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) +import UnliftIO + ( TVar + , atomically + , concurrently + , forConcurrently + , modifyTVar + , newTVarIO + , readTVarIO + , try + ) import UnliftIO.Pool import Prelude @@ -45,7 +56,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 @@ -55,19 +66,23 @@ spec = do queryEventsSpec migrationSpec -- make sure migrationSpec is run last! processedEvents <- runIO $ newTVarIO (Set.empty :: Set UUID) + hookDone <- runIO newChan let postHook - :: PostgresEvent TestModel TestEvent + :: PostgresEvent NoIndex TestModel 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])) - in around (setupPersistance postHook) (postHookSpec processedEvents) + when (m < 0) (void $ runCmd p index $ \_ -> pure (id, [Reset])) + writeChan hookDone () + in around (setupPersistance postHook) (postHookSpec hookDone processedEvents) around (setupPersistance noHook) migrationConcurrencySpec around (setupPersistance noHook) loggingSpec + around setupPersistanceIndexed indexedSpec type TestModel = Int @@ -83,12 +98,22 @@ applyTestEvent m ev = case storedEvent ev of SubtractOne -> m - 1 Reset -> 0 -noHook :: PostgresEvent TestModel TestEvent -> TestModel -> [Stored TestEvent] -> IO () -noHook _ _ _ = pure () +noHook + :: PostgresEvent NoIndex TestModel TestEvent + -> NoIndex + -> TestModel + -> [Stored TestEvent] + -> IO () +noHook _ _ _ _ = pure () setupPersistance - :: (PostgresEvent TestModel TestEvent -> TestModel -> [Stored TestEvent] -> IO ()) - -> ((PostgresEvent TestModel 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 @@ -103,6 +128,19 @@ setupPersistance postHook test = do , pool ) +setupPersistanceIndexed + :: ((PostgresEvent Indexed TestModel 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 $ @@ -130,7 +168,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 NoIndex TestModel TestEvent, Pool Connection) writeEventsSpec = describe "queryEvents" $ do let ev1 :: Stored TestEvent ev1 = @@ -141,11 +179,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 @@ -159,28 +197,86 @@ writeEventsSpec = describe "queryEvents" $ do (\e -> Stored e (UTCTime (fromGregorian 2020 10 15) 10) <$> mkId) evs _ <- withResource pool $ \conn -> - writeEvents conn (getEventTableName eventTable) storedEvs - evs' <- getEventList p + writeEvents conn (getEventTableName eventTable) NoIndex storedEvs + evs' <- getEventList p NoIndex drop (length evs' - 2) (fmap storedEvent evs') `shouldBe` evs -streamingSpec :: SpecWith (PostgresEvent TestModel 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] + 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 + + it "Updates to different indices can be done in parallel" $ \(p, _pool) -> do + let testCmd :: Int -> TestModel -> IO (TestModel -> TestModel, [TestEvent]) + testCmd i _ = do + threadDelay 100000 -- 0.1s delay + 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 + + t1 <- getCurrentTime + + models `shouldSatisfy` (== 20) . length + 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 :: TestModel -> IO (TestModel -> TestModel, [TestEvent]) + testCmd _ = do + threadDelay 100000 -- 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]) . 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 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 + writeEvents conn (getEventTableName eventTable) NoIndex storedEvs + 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 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) + 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 @@ -192,6 +288,7 @@ queryEventsSpec = describe "queryEvents" $ do writeEvents conn (getEventTableName eventTable) + NoIndex [Stored ev1 (UTCTime (fromGregorian 2020 10 20) 1) id1] id2 <- mkId @@ -199,47 +296,48 @@ queryEventsSpec = describe "queryEvents" $ do writeEvents conn (getEventTableName eventTable) + NoIndex [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) -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 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 + readChan hookDone events <- readTVarIO processedEvents Set.size events `shouldBe` 3 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 + readChan hookDone + m' <- getModel p NoIndex m' `shouldBe` 0 -migrationSpec :: SpecWith (PostgresEvent TestModel 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 -> - 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 @@ -250,7 +348,9 @@ 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 @@ -261,7 +361,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 @@ -287,14 +388,15 @@ migrationSpec = describe "migrate1to1" $ do brokenExists `shouldBe` False _ -> fail "Unexpectedly lacking table versions!" -migrationConcurrencySpec :: SpecWith (PostgresEvent 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 it "migrate1toManyWithState" $ \(m0, pool) -> migrationTest m0 pool mig1toManyState where migrationTest - :: PostgresEvent TestModel TestEvent + :: PostgresEvent NoIndex TestModel TestEvent -> Pool Connection -> EventMigration -> IO () @@ -302,13 +404,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 +423,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 +445,23 @@ migrationConcurrencySpec = describe "Event table is locked during migration" $ d threadDelay 250000 pure a -loggingSpec :: SpecWith (PostgresEvent TestModel 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' - _ <- 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 +469,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 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/README.md b/domaindriven-examples/README.md new file mode 100644 index 0000000..9c47d2d --- /dev/null +++ b/domaindriven-examples/README.md @@ -0,0 +1,43 @@ +# DomainDriven Examples + +Example applications demonstrating the domaindriven library. +All three examples use a simple counter domain to keep the focus on the library features. + +## Examples + +### 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. + +```bash +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 +``` + +### 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`. + +Requires a running PostgreSQL instance: +```bash +createdb -U postgres domaindriven +``` + +```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 +``` + +### 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-examples/domaindriven-examples.cabal b/domaindriven-examples/domaindriven-examples.cabal index 19d1fde..1a29579 100644 --- a/domaindriven-examples/domaindriven-examples.cabal +++ b/domaindriven-examples/domaindriven-examples.cabal @@ -1,34 +1,27 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.36.0. --- --- see: https://github.com/sol/hpack +cabal-version: 3.12 name: domaindriven-examples version: 0.5.0 -synopsis: Batteries included event sourcing and CQRS -description: Please see the README on GitHub at +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 author: Tommy Engström maintainer: tommy@tommyengstrom.com -copyright: 2022 Tommy Engström -license: BSD3 +copyright: 2025 Tommy Engström +license: BSD-3-Clause build-type: Simple +extra-source-files: + README.md 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 +common shared_opts default-extensions: - Arrows + BlockArguments ConstraintKinds DataKinds DeriveAnyClass @@ -53,112 +46,87 @@ executable hierarchical-example PolyKinds RankNTypes ScopedTypeVariables - ImportQualifiedPost StandaloneDeriving + StrictData TupleSections TypeApplications TypeFamilyDependencies TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -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 - , async , base - , bytestring - , containers - , deepseq - , domaindriven , domaindriven-core - , exceptions - , generic-lens - , generics-sop - , http-types - , microlens - , mtl + , domaindriven + , effectful + , effectful-core + , effectful-plugin , postgresql-simple - , random + , shape-coerce + , servant , servant-server - , streamly - , template-haskell - , time - , transformers - , unliftio - , unliftio-pool - , unordered-containers - , uuid - , vector , warp - default-language: Haskell2010 executable simple-example + import: shared_opts main-is: Main.hs - other-modules: - Paths_domaindriven_examples hs-source-dirs: simple - default-extensions: - Arrows - 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 -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -threaded -rtsopts -with-rtsopts=-N build-depends: aeson - , async , base - , bytestring - , containers - , deepseq - , domaindriven , domaindriven-core - , exceptions - , generic-lens - , generics-sop - , http-types - , microlens - , mtl - , postgresql-simple - , random + , domaindriven + , effectful + , effectful-core + , effectful-plugin + , servant , servant-server - , streamly - , template-haskell , time - , transformers - , unliftio - , unliftio-pool - , unordered-containers , uuid - , vector , warp - default-language: Haskell2010 + +executable fieldname-as-path-example + import: shared_opts + main-is: Main.hs + hs-source-dirs: + fieldname-as-path + build-depends: + aeson + , base + , domaindriven-core + , domaindriven + , effectful + , effectful-core + , effectful-plugin + , servant + , servant-server + , warp diff --git a/domaindriven-examples/fieldname-as-path/Main.hs b/domaindriven-examples/fieldname-as-path/Main.hs new file mode 100644 index 0000000..1c84121 --- /dev/null +++ b/domaindriven-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 +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-examples/hierarchical/Main.hs b/domaindriven-examples/hierarchical/Main.hs deleted file mode 100644 index d221d4d..0000000 --- a/domaindriven-examples/hierarchical/Main.hs +++ /dev/null @@ -1,138 +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 - , 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/intro.txt b/domaindriven-examples/intro.txt new file mode 100644 index 0000000..4895d79 --- /dev/null +++ b/domaindriven-examples/intro.txt @@ -0,0 +1,7 @@ +# DomainDriven + +## Design decisions + +- Avoid the complexity of ascynchronous event sourcing +- Convenient for the end user +- Easy to migrate events diff --git a/domaindriven-examples/package.yaml b/domaindriven-examples/package.yaml deleted file mode 100644 index 2ea749b..0000000 --- a/domaindriven-examples/package.yaml +++ /dev/null @@ -1,110 +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 -- async -- bytestring -- containers -- deepseq -- exceptions -- generic-lens -- http-types -- microlens -- mtl -- postgresql-simple -- random -- generics-sop -- servant-server -- warp -- streamly -- template-haskell -- time -- transformers -- unliftio -- unliftio-pool -- unordered-containers -- uuid -- vector - - -default-extensions: -- Arrows -- 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 -- -Wcompat -- -Widentities -- -Wincomplete-record-updates -- -Wincomplete-uni-patterns -- -Wpartial-fields -- -Wredundant-constraints -- -Wincomplete-record-updates -- -Wincomplete-patterns - -executables: - simple-example: - main: Main.hs - source-dirs: simple - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - hierarchical-example: - main: Main.hs - source-dirs: hierarchical - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N diff --git a/domaindriven-examples/postgres/Event/V1.hs b/domaindriven-examples/postgres/Event/V1.hs new file mode 100644 index 0000000..06a84d4 --- /dev/null +++ b/domaindriven-examples/postgres/Event/V1.hs @@ -0,0 +1,10 @@ +module Event.V1 where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) +import Prelude + +data CounterEvent + = CounterIncreased + | CounterDecreased + deriving (Show, Generic, FromJSON, ToJSON) diff --git a/domaindriven-examples/postgres/Event/V2.hs b/domaindriven-examples/postgres/Event/V2.hs new file mode 100644 index 0000000..316c01b --- /dev/null +++ b/domaindriven-examples/postgres/Event/V2.hs @@ -0,0 +1,10 @@ +module Event.V2 where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) +import Prelude + +data CounterEvent + = CounterIncreasedBy Int + | CounterDecreasedBy Int + deriving (Show, Generic, FromJSON, ToJSON) diff --git a/domaindriven-examples/postgres/EventMigration.hs b/domaindriven-examples/postgres/EventMigration.hs new file mode 100644 index 0000000..d2ef708 --- /dev/null +++ b/domaindriven-examples/postgres/EventMigration.hs @@ -0,0 +1,47 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module EventMigration (eventTable) where + +import Data.ShapeCoerce +import Database.PostgreSQL.Simple (Connection) +import DomainDriven.Persistance.Class +import DomainDriven.Persistance.Postgres +import DomainDriven.Persistance.Postgres.Migration +import Event.V1 qualified as V1 +import Event.V2 qualified as V2 +import Prelude + +fixEvent :: Stored V1.CounterEvent -> Stored V2.CounterEvent +fixEvent = shapeCoerce + +-- Automatic ShapeCoercible fails because the constructor names changed: +-- +-- • Cannot shapeCoerce between types: +-- From: V1.CounterEvent +-- To: V2.CounterEvent +-- +-- Reason: Constructor name mismatch +-- 'CounterIncreased ≠ 'CounterIncreasedBy +-- +-- Solution: Write instance `ShapeCoercible V1.CounterEvent V2.CounterEvent` + +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 + migrate1to1 @NoIndex + conn + prevEtName + etName + fixEvent + +eventTable :: EventTable +eventTable = + MigrateUsing migrate + $ InitialVersion "counter_events" diff --git a/domaindriven-examples/postgres/Main.hs b/domaindriven-examples/postgres/Main.hs new file mode 100644 index 0000000..6fd31c5 --- /dev/null +++ b/domaindriven-examples/postgres/Main.hs @@ -0,0 +1,121 @@ +-- | 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 Database.PostgreSQL.Simple (connectPostgreSQL) +import DomainDriven +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 +import Servant.API.Generic +import Servant.Server.Generic (AsServerT, genericServeT) +import Prelude + +-------------------------------------------------------------------------------- +-- Define the model +-------------------------------------------------------------------------------- +type CounterModel = Int + +-------------------------------------------------------------------------------- +-- Define event handler (using V2 events) +-------------------------------------------------------------------------------- +applyEvent :: CounterModel -> Stored CounterEvent -> CounterModel +applyEvent i (Stored ev _timestamp _uuid) = case ev of + CounterIncreasedBy n -> i + n + CounterDecreasedBy n -> i - n + +-- | Domain type carrying model, event, and index constraints. +type CounterDomain = Domain CounterModel CounterEvent NoIndex + +-------------------------------------------------------------------------------- +-- Use Servant to define the API +-------------------------------------------------------------------------------- +data CounterAPI mode = CounterAPI + { get :: mode :- Get '[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 +-------------------------------------------------------------------------------- +counterServer + :: ( Projection CounterDomain Effectful.:> es + , Aggregate CounterDomain Effectful.:> es + , Error ServerError Effectful.:> es + ) + => CounterAPI (AsServerT (Eff es)) +counterServer = + CounterAPI + { get = getModel + , increase = \amount -> runTransaction \_ -> do + pure (id, [CounterIncreasedBy amount]) + , decrease = \amount -> runTransaction \m -> do + when + (m - amount < 0) + (throwError err422{errBody = "Counter cannot go below zero"}) + pure (id, [CounterDecreasedBy amount]) + } + +-------------------------------------------------------------------------------- +-- Create the servant application +-------------------------------------------------------------------------------- +mkCounterServer + :: PostgresEvent NoIndex CounterModel CounterEvent + -> Application +mkCounterServer backend = + genericServeT runEffects 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 = 7879 + putStrLn $ "Running Effectful counter (Postgres) on port " <> show port + + -- Initialize the PostgreSQL backend with event migration + 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-examples/simple/Main.hs b/domaindriven-examples/simple/Main.hs index f8c48eb..5579296 100644 --- a/domaindriven-examples/simple/Main.hs +++ b/domaindriven-examples/simple/Main.hs @@ -1,81 +1,146 @@ +-- | 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 Data.Aeson -import DomainDriven hiding (applyEvent) -import DomainDriven.Persistance.ForgetfulInMemory (createForgetful) -import GHC.Generics (Generic) +import Control.Monad (when) +import Data.Aeson (FromJSON, ToJSON) +import Data.Time (UTCTime) +import Data.UUID (UUID) +import DomainDriven +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.Server.Generic +import Servant hiding (throwError) +import Servant qualified +import Servant.API.Generic +import Servant.Server.Generic (AsServerT, genericServeT) import Prelude -------------------------------------------------------------------------------- --- 1. Define the model +-- Define the model -------------------------------------------------------------------------------- -newtype CounterModel = CounterModel {getCounter :: Int} - deriving (Show, Eq, Generic) +data CounterModel = CounterModel + { counter :: Int + , previousCounter :: Int + } deriving (Show, Generic) + -------------------------------------------------------------------------------- --- 2. Define events and how to apply them +-- Define events -------------------------------------------------------------------------------- data CounterEvent - = Increase - | Decrease - deriving (Show, Eq, Generic, ToJSON, FromJSON) + = CounterIncreased + | CounterDecreased + deriving (Show, Generic, ToJSON, FromJSON) +-------------------------------------------------------------------------------- +-- Define event handler +-------------------------------------------------------------------------------- applyEvent :: CounterModel -> Stored CounterEvent -> CounterModel -applyEvent (CounterModel i) (Stored ev _ _) = CounterModel $ 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 + -------------------------------------------------------------------------------- --- 3. Define the API, i.e. the commands and queries +-- Use Servant to define the API -------------------------------------------------------------------------------- -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]) - } +-- | Envelope for returning stored events over JSON. +data StoredEvent = StoredEvent + { event :: CounterEvent + , timestamp :: UTCTime + , uuid :: UUID + } + deriving (Show, Generic, ToJSON) --- 4. Define the final API type using `DomainDrivenApi`, which uses the labels of the --- record to add a path piece to the final endpoints. +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) -type ServantCounterApi = DomainDrivenApi CounterApi CounterModel CounterEvent +-------------------------------------------------------------------------------- +-- Implement the server handlers using Effectful effects +-------------------------------------------------------------------------------- --- 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 +type CounterDomain = Domain CounterModel CounterEvent NoIndex --- FIXME: This should be the default implementation imo -instance ApiTagFromLabel CounterApi where - apiTagFromLabel = id +-- | 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 = 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]) + , events = do + storedEvents <- getEventList + pure $ map toStoredEvent storedEvents + } + where + toStoredEvent :: Stored CounterEvent -> StoredEvent + toStoredEvent (Stored ev ts uid) = StoredEvent ev ts uid -app - :: Model p ~ CounterModel - => Event p ~ CounterEvent - => WriteModel p - => p +-------------------------------------------------------------------------------- +-- 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 -app p = - serveWithContext - (Proxy @ServantCounterApi) - (ReadPersistence p :. WritePersistence p :. EmptyContext) - counterServer +mkCounterServer backend = + genericServeT runEffects 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 = 7878 - putStrLn $ "Running on port " <> show port - p <- createForgetful applyEvent (CounterModel 0) - run port (app p) + putStrLn $ "Running Effectful counter on port " <> show port + + -- Initialize the in-memory backend + backend <- createForgetful applyEvent (CounterModel 0 0) + + -- Create and run the application + run port $ mkCounterServer backend 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 index 2af6acc..e69de29 100644 --- a/domaindriven/README.md +++ b/domaindriven/README.md @@ -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 index b8c5a4e..fb5dc53 100644 --- a/domaindriven/domaindriven.cabal +++ b/domaindriven/domaindriven.cabal @@ -1,9 +1,4 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.36.0. --- --- see: https://github.com/sol/hpack - +cabal-version: 3.12 name: domaindriven version: 0.5.0 synopsis: Batteries included event sourcing and CQRS @@ -14,29 +9,16 @@ 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 - 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 +common shared_opts default-extensions: ConstraintKinds DataKinds @@ -58,6 +40,8 @@ library NamedFieldPuns NoImplicitPrelude OverloadedLabels + AllowAmbiguousTypes + BlockArguments OverloadedStrings PolyKinds RankNTypes @@ -70,109 +54,67 @@ 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 + -Wno-missing-import-lists + -fplugin=Effectful.Plugin + default-language: Haskell2010 + +library + import: shared_opts + exposed-modules: + DomainDriven + DomainDriven.Aggregate + DomainDriven.Domain + DomainDriven.Interpreter + DomainDriven.Projection + DomainDriven.FieldNameAsPath + Servant.Auth.Internal.ThrowAll.SOP + hs-source-dirs: + src build-depends: - aeson - , async - , base + base , bytestring - , constraints - , containers - , deepseq , domaindriven-core - , exceptions - , generic-lens + , effectful-core + , effectful-plugin + , effectful-th , generics-sop - , http-types - , microlens - , mtl , openapi3 - , optics - , postgresql-simple - , random - , resource-pool - , servant , servant-auth-server , servant-client-core , servant-openapi3 , servant-server - , streamly - , template-haskell , text - , time - , transformers - , unliftio - , unordered-containers - , uuid - , vector - default-language: Haskell2010 test-suite domaindriven-test + import: shared_opts type: exitcode-stdio-1.0 main-is: Spec.hs + ghc-options: + -threaded + -rtsopts + -with-rtsopts=-N + build-tool-depends: + hspec-discover:hspec-discover other-modules: - Paths_domaindriven + DomainDriven.InMemorySpec 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 -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 + test build-depends: - QuickCheck - , aeson - , async - , base - , constraints - , containers - , deepseq - , domaindriven + base , domaindriven-core - , exceptions - , generics-sop + , domaindriven + , effectful-core + , effectful-plugin , hspec - , http-client - , mtl - , openapi3 - , optics - , quickcheck-arbitrary-adt - , quickcheck-classes - , servant - , servant-auth-server - , servant-client - , servant-client-core - , servant-openapi3 - , servant-server - , text - , warp - default-language: Haskell2010 diff --git a/domaindriven/package.yaml b/domaindriven/package.yaml deleted file mode 100644 index 9888508..0000000 --- a/domaindriven/package.yaml +++ /dev/null @@ -1,130 +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: -- aeson -- base -- containers -- deepseq -- exceptions -- openapi3 -- servant-server -- servant-client-core -- servant -- text -- domaindriven-core -- generics-sop -- constraints -- servant-openapi3 -- optics -- servant-auth-server - - -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 -- -Wcompat -- -Widentities -- -Wincomplete-record-updates -- -Wincomplete-uni-patterns -- -Wpartial-fields -- -Wredundant-constraints -- -Wincomplete-record-updates -- -Wincomplete-patterns -- -Wunused-packages -- -Wall-missed-specialisations - -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 diff --git a/domaindriven/src/DomainDriven.hs b/domaindriven/src/DomainDriven.hs index 5b6c093..50b7120 100644 --- a/domaindriven/src/DomainDriven.hs +++ b/domaindriven/src/DomainDriven.hs @@ -1,39 +1,14 @@ -module DomainDriven (module X) where +module DomainDriven + ( -- * Domain configuration (re-exported) + module DomainDriven.Domain -import Data.UUID as X (UUID) - -import DomainDriven.Persistance.Class as X - ( ReadModel (..) - , Stored (..) - , WriteModel (..) - , mkId - , runCmd - ) -import DomainDriven.Server.Api as X - ( CbCmd - , CbQuery - , Cmd - , Field (..) - , JsonObject (..) - , NamedField (..) - , Query - ) -import DomainDriven.Server.DomainDrivenApi as X - ( ApiTagFromLabel (..) - , DomainDrivenApi - , DomainDrivenServer (..) + -- * Effects and helpers + , module X ) -import DomainDriven.Server.MapModel as X - ( MapEvent (..) - , MapModel (..) - , MapModelAndEvent (..) - ) -import DomainDriven.Server.Server as X - ( CbCmdServer (..) - , CbQueryServer (..) - , CmdServer (..) - , QueryServer (..) - , ReadPersistence (..) - , WritePersistence (..) - ) -import Generics.SOP.NP as X (NP (..)) +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/src/DomainDriven/Aggregate.hs b/domaindriven/src/DomainDriven/Aggregate.hs new file mode 100644 index 0000000..2f4e35f --- /dev/null +++ b/domaindriven/src/DomainDriven/Aggregate.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +module DomainDriven.Aggregate where + +import Data.Kind (Type) +import Data.Type.Equality +import DomainDriven.Domain +import DomainDriven.Persistance.Class (NoIndex (..)) +import Effectful +import Effectful.TH + +-- | The new Aggregate effect with a single domain parameter +data Aggregate (domain :: Type) :: Effect where + RunTransactionI + :: DomainIndex domain + -> ( DomainModel domain + -> Eff + es + ( DomainModel domain -> a + , [DomainEvent domain] + ) + ) + -> Aggregate domain (Eff es) a + +type instance DispatchOf (Aggregate domain) = 'Dynamic + +$(makeEffect ''Aggregate) + +runTransaction + :: forall domain es a + . Aggregate domain :> es + => DomainIndex domain ~ NoIndex + => ( DomainModel domain -> Eff + es + ( DomainModel domain -> a + , [DomainEvent domain] + ) + ) + -> Eff es a +runTransaction = runTransactionI NoIndex diff --git a/domaindriven/src/DomainDriven/Domain.hs b/domaindriven/src/DomainDriven/Domain.hs new file mode 100644 index 0000000..1cf305b --- /dev/null +++ b/domaindriven/src/DomainDriven/Domain.hs @@ -0,0 +1,20 @@ +module DomainDriven.Domain + ( module DomainDriven.Domain + ) where + +import Data.Kind (Type) + +-- | 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 diff --git a/domaindriven/src/DomainDriven/Server/DomainDrivenApi.hs b/domaindriven/src/DomainDriven/FieldNameAsPath.hs similarity index 61% rename from domaindriven/src/DomainDriven/Server/DomainDrivenApi.hs rename to domaindriven/src/DomainDriven/FieldNameAsPath.hs index d4bcf62..6a23135 100644 --- a/domaindriven/src/DomainDriven/Server/DomainDrivenApi.hs +++ b/domaindriven/src/DomainDriven/FieldNameAsPath.hs @@ -3,13 +3,12 @@ {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE UndecidableInstances #-} -module DomainDriven.Server.DomainDrivenApi where +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 DomainDriven.Server.Helper.GenericRecord import GHC.Generics qualified as GHC import GHC.TypeLits import Generics.SOP @@ -32,42 +31,34 @@ 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 +-- data CounterAction mode = CounterAction +-- { increaseWith :: mode :- "something" :> ReqBody '[JSON] Int :> Cmd Int -- } -- ``` -- Will result in a Post endpoint with path "something/increaseWith". -data - DomainDrivenApi - (mkApiRecord :: Type -> Type -> Type -> Type) - (model :: Type) - (event :: Type) +data FieldNameAsPathApi (mkApiRecord :: Type -> Type) -class ApiTagFromLabel (mkApiRecord :: Type -> Type -> Type -> Type) where +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 `DomainDrivenApi`. i.e. --- this is what the `ServerT` type family will produce when given a `DomainDrivenApi`. +-- 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 - DomainDrivenServer - (mkServerRecord :: Type -> Type -> Type -> Type) - (model :: Type) - (event :: Type) - (m :: Type -> Type) = DomainDrivenServer + FieldNameAsPathServer + (mkServerRecord :: Type -> Type) + (m :: Type -> Type) = FieldNameAsPathServer { unDomainDrivenServer - :: mkServerRecord model event (AsServerT m) + :: mkServerRecord (AsServerT m) } deriving newtype instance - GHC.Generic (mkServerRecord model event (AsServerT m)) - => GHC.Generic (DomainDrivenServer mkServerRecord model event m) + GHC.Generic (mkServerRecord (AsServerT m)) + => GHC.Generic (FieldNameAsPathServer mkServerRecord m) class DomainDrivenServerFields (mkApiRecord :: Type -> Type) (m :: Type -> Type) where recordOfServersFromFields @@ -92,11 +83,9 @@ instance S y -> case y of {} class - DomainDrivenApiHasServers - (mkApiRecord :: Type -> Type -> Type -> Type) - (model :: Type) - (event :: Type) - (apis :: [Api]) + FieldNamesInPathHasServers + (mkApiRecord :: Type -> Type) + (apis :: [Type]) (infos :: [FieldInfo]) (context :: [Type]) where @@ -110,21 +99,19 @@ class -> NP I (ServerTs apis m) -> NP I (ServerTs apis n) -instance DomainDrivenApiHasServers mkApiRecord model event '[] '[] context where +instance FieldNamesInPathHasServers mkApiRecord '[] '[] context where type ServerTs '[] m = '[] taggedSumOfRoutes _ _ = StaticRouter mempty mempty hoistTaggedServersWithContext _ Nil = Nil instance ( HasServer api context - , DomainDrivenApiHasServers mkApiRecord model event apis infos context + , FieldNamesInPathHasServers mkApiRecord apis infos context , KnownSymbol label , ApiTagFromLabel mkApiRecord ) - => DomainDrivenApiHasServers + => FieldNamesInPathHasServers mkApiRecord - model - event (api ': apis) ('FieldInfo label ': infos) context @@ -138,66 +125,64 @@ instance $ route (Proxy @api) context $ (\(I server :* _) -> server) <$> delayedServers ) - ( taggedSumOfRoutes @mkApiRecord @model @event @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 @model @event @apis @infos @context nt servers + :* hoistTaggedServersWithContext @mkApiRecord @apis @infos @context nt servers instance - ( DomainDrivenApiHasServers + ( FieldNamesInPathHasServers mkApiRecord - model - event - (GenericRecordFields (mkApiRecord model event AsApi)) - (GenericRecordFieldInfos (mkApiRecord model event AsApi)) + (GenericRecordFields (mkApiRecord AsApi)) + (GenericRecordFieldInfos (mkApiRecord AsApi)) context - , forall m. DomainDrivenServerFields (mkApiRecord model event) m + , forall m. DomainDrivenServerFields (mkApiRecord) m ) - => HasServer (DomainDrivenApi mkApiRecord model event) context + => HasServer (FieldNameAsPathApi mkApiRecord) context where type - ServerT (DomainDrivenApi mkApiRecord model event) m = - DomainDrivenServer mkApiRecord model event m + ServerT (FieldNameAsPathApi mkApiRecord) m = + FieldNameAsPathServer mkApiRecord m route _ context delayedServer = - taggedSumOfRoutes @mkApiRecord @model @event - @(GenericRecordFields (mkApiRecord model event AsApi)) - @(GenericRecordFieldInfos (mkApiRecord model event AsApi)) + taggedSumOfRoutes @mkApiRecord + @(GenericRecordFields (mkApiRecord AsApi)) + @(GenericRecordFieldInfos (mkApiRecord AsApi)) context (recordOfServersToFields . unDomainDrivenServer <$> delayedServer) hoistServerWithContext _ _ nt servers = - DomainDrivenServer + FieldNameAsPathServer . recordOfServersFromFields - . hoistTaggedServersWithContext @mkApiRecord @model @event - @(GenericRecordFields (mkApiRecord model event AsApi)) - @(GenericRecordFieldInfos (mkApiRecord model event AsApi)) + . hoistTaggedServersWithContext @mkApiRecord + @(GenericRecordFields (mkApiRecord AsApi)) + @(GenericRecordFieldInfos (mkApiRecord AsApi)) @context nt . recordOfServersToFields $ unDomainDrivenServer servers class - DomainDrivenApiHasOpenApi - (mkApiRecord :: Type -> Type -> Type -> Type) - (apis :: [Api]) + FieldNamesInPathHasOpenApi + (mkApiRecord :: Type -> Type) + (apis :: [Type]) (infos :: [FieldInfo]) where domainDrivenApiToOpenApi :: OpenApi -instance DomainDrivenApiHasOpenApi mkApiRecord '[] '[] where +instance FieldNamesInPathHasOpenApi mkApiRecord '[] '[] where domainDrivenApiToOpenApi = mempty instance ( KnownSymbol label , ApiTagFromLabel mkApiRecord , HasOpenApi api - , DomainDrivenApiHasOpenApi mkApiRecord apis infos + , FieldNamesInPathHasOpenApi mkApiRecord apis infos ) - => DomainDrivenApiHasOpenApi mkApiRecord (api ': apis) ('FieldInfo label ': infos) + => FieldNamesInPathHasOpenApi mkApiRecord (api ': apis) ('FieldInfo label ': infos) where domainDrivenApiToOpenApi = prependPath @@ -206,31 +191,31 @@ instance <> domainDrivenApiToOpenApi @mkApiRecord @apis @infos instance - DomainDrivenApiHasOpenApi + FieldNamesInPathHasOpenApi mkApiRecord - (GenericRecordFields (mkApiRecord model event AsApi)) - (GenericRecordFieldInfos (mkApiRecord model event AsApi)) - => HasOpenApi (DomainDrivenApi mkApiRecord model event) + (GenericRecordFields (mkApiRecord AsApi)) + (GenericRecordFieldInfos (mkApiRecord AsApi)) + => HasOpenApi (FieldNameAsPathApi mkApiRecord) where toOpenApi _ = domainDrivenApiToOpenApi @mkApiRecord - @(GenericRecordFields (mkApiRecord model event AsApi)) - @(GenericRecordFieldInfos (mkApiRecord model event AsApi)) + @(GenericRecordFields (mkApiRecord AsApi)) + @(GenericRecordFieldInfos (mkApiRecord AsApi)) instance - ( GHC.Generic (DomainDrivenServer mkServerRecord model event m) - , GTo (DomainDrivenServer mkServerRecord model event m) - , ThrowAll (SOP I (GCode (DomainDrivenServer mkServerRecord model event m))) + ( GHC.Generic (FieldNameAsPathServer mkServerRecord m) + , GTo (FieldNameAsPathServer mkServerRecord m) + , ThrowAll (SOP I (GCode (FieldNameAsPathServer mkServerRecord m))) ) - => ThrowAll (DomainDrivenServer mkServerRecord model event m) + => ThrowAll (FieldNameAsPathServer mkServerRecord m) where - throwAll = gto . throwAll @(SOP I (GCode (DomainDrivenServer mkServerRecord model event m))) + throwAll = gto . throwAll @(SOP I (GCode (FieldNameAsPathServer mkServerRecord m))) class - DomainDrivenApiHasClients + FieldNamesInPathHasClients (m :: Type -> Type) - (mkApiRecord :: Type -> Type -> Type -> Type) - (apis :: [Api]) + (mkApiRecord :: Type -> Type) + (apis :: [Type]) (infos :: [FieldInfo]) where type Clients apis m :: [Type] @@ -240,18 +225,18 @@ class -> NP I (Clients apis mon) -> NP I (Clients apis mon') -instance DomainDrivenApiHasClients m mkApiRecord '[] '[] where +instance FieldNamesInPathHasClients m mkApiRecord '[] '[] where type Clients '[] m = '[] clientsWithRoute _ = Nil hoistClientsMonad _ Nil = Nil instance ( HasClient m api - , DomainDrivenApiHasClients m mkApiRecord apis infos + , FieldNamesInPathHasClients m mkApiRecord apis infos , KnownSymbol label , ApiTagFromLabel mkApiRecord ) - => DomainDrivenApiHasClients m mkApiRecord (api ': apis) ('FieldInfo label ': infos) + => FieldNamesInPathHasClients m mkApiRecord (api ': apis) ('FieldInfo label ': infos) where type Clients (api ': apis) m = Client m api ': Clients apis m @@ -294,28 +279,42 @@ instance instance ( RunClient m - , DomainDrivenApiHasClients + , FieldNamesInPathHasClients m mkApiRecord - (GenericRecordFields (mkApiRecord model event AsApi)) - (GenericRecordFieldInfos (mkApiRecord model event AsApi)) - , forall n. DomainDrivenClientFields (mkApiRecord model event) n + (GenericRecordFields (mkApiRecord AsApi)) + (GenericRecordFieldInfos (mkApiRecord AsApi)) + , forall n. DomainDrivenClientFields (mkApiRecord) n ) - => HasClient m (DomainDrivenApi mkApiRecord model event) + => HasClient m (FieldNameAsPathApi mkApiRecord) where type - Client m (DomainDrivenApi mkApiRecord model event) = - mkApiRecord model event (AsClientT m) + Client m (FieldNameAsPathApi mkApiRecord) = + mkApiRecord (AsClientT m) clientWithRoute _ _ = recordOfClientsFromFields . ( clientsWithRoute @m @mkApiRecord - @(GenericRecordFields (mkApiRecord model event AsApi)) - @(GenericRecordFieldInfos (mkApiRecord model event AsApi)) + @(GenericRecordFields (mkApiRecord AsApi)) + @(GenericRecordFieldInfos (mkApiRecord AsApi)) ) hoistClientMonad _ _ nt = recordOfClientsFromFields . hoistClientsMonad @m @mkApiRecord - @(GenericRecordFields (mkApiRecord model event AsApi)) - @(GenericRecordFieldInfos (mkApiRecord model event AsApi)) + @(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/src/DomainDriven/Interpreter.hs b/domaindriven/src/DomainDriven/Interpreter.hs new file mode 100644 index 0000000..c3cb1e3 --- /dev/null +++ b/domaindriven/src/DomainDriven/Interpreter.hs @@ -0,0 +1,50 @@ +module DomainDriven.Interpreter + ( runAggregate + , runProjection + ) where + +import DomainDriven.Aggregate +import DomainDriven.Domain +import DomainDriven.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/src/DomainDriven/Projection.hs b/domaindriven/src/DomainDriven/Projection.hs new file mode 100644 index 0000000..81fd1a4 --- /dev/null +++ b/domaindriven/src/DomainDriven/Projection.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module DomainDriven.Projection where + +import Data.Type.Equality +import DomainDriven.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 + -> 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 + +$(makeEffect ''Projection) + +getModel + :: forall 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 + ) + => Eff es [Stored (DomainEvent domain)] +getEventList = getEventListI NoIndex diff --git a/domaindriven/src/DomainDriven/Server/Api.hs b/domaindriven/src/DomainDriven/Server/Api.hs deleted file mode 100644 index 4009b7e..0000000 --- a/domaindriven/src/DomainDriven/Server/Api.hs +++ /dev/null @@ -1,173 +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) - -instance HasOpenApi verb => HasOpenApi (Cmd' 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 (Query' model verb) where - toOpenApi _ = toOpenApi $ Proxy @verb - -instance HasOpenApi verb => HasOpenApi (CbQuery' 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 (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 (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 (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 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 df764fe..0000000 --- a/domaindriven/src/DomainDriven/Server/Server.hs +++ /dev/null @@ -1,161 +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 - -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 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 - -instance - ( HasServer (Verb method status ctypes a) context - , CanMutate method ~ 'True - , HasContextEntry context (WritePersistence model 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 event of - WritePersistence p -> - route (Proxy @(Verb method status ctypes a)) context $ - mapServer - ( \(Cmd server) -> do - handlerRes <- - liftIO . Control.Monad.Catch.try . runCmd p $ - either throwIO pure <=< runHandler . server - either throwError pure handlerRes - ) - delayedServer - -instance - ( HasServer (Verb method status ctypes a) context - , HasContextEntry context (ReadPersistence model) - ) - => 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 of - ReadPersistence p -> - route (Proxy @(Verb method status ctypes a)) context $ - mapServer - ( \(Query server) -> server =<< liftIO (getModel p) - ) - delayedServer - -instance - ( HasServer (Verb method status ctypes a) context - , HasContextEntry context (ReadPersistence model) - ) - => 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 of - ReadPersistence p -> - route (Proxy @(Verb method status ctypes a)) context $ - mapServer - ( \(CbQuery server) -> server (liftIO $ getModel p) - ) - delayedServer - -instance - ( HasServer (Verb method status ctypes a) context - , CanMutate method ~ 'True - , HasContextEntry context (WritePersistence model 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 event of - WritePersistence p -> - route (Proxy @(Verb method status ctypes a)) context $ - mapServer - ( \(CbCmd server) -> server $ runCmd p - ) - delayedServer diff --git a/domaindriven/test/DomainDriven/InMemorySpec.hs b/domaindriven/test/DomainDriven/InMemorySpec.hs new file mode 100644 index 0000000..efa15a5 --- /dev/null +++ b/domaindriven/test/DomainDriven/InMemorySpec.hs @@ -0,0 +1,146 @@ +module DomainDriven.InMemorySpec (spec) where + +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 +import Test.Hspec +import Control.Concurrent.Chan (newChan, readChan, writeChan) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +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 + . 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 + -> Eff '[Aggregate IndexedTestDomain, Projection IndexedTestDomain, IOE] a + -> IO a +runIndexedTest backend = + runEff + . runProjection backend + . runAggregate 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 + + 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/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 new file mode 100644 index 0000000..7866e38 --- /dev/null +++ b/flake.nix @@ -0,0 +1,43 @@ +{ + 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.haskell.packages.ghc9103.hspec-discover + 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" + exec ${pkgs.fish}/bin/fish + ''; + }; + }); +} diff --git a/run-ghcid.sh b/run-ghcid.sh new file mode 100755 index 0000000..cb849b7 --- /dev/null +++ b/run-ghcid.sh @@ -0,0 +1,30 @@ +#!/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" | 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 "domaindriven-core/domaindriven-core.cabal" \ + --restart "domaindriven/domaindriven.cabal" \ + --restart "domaindriven-examples/domaindriven-examples.cabal" \ + -o $LOG_FILE 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/shape-coerce/src/Data/ShapeCoerce.hs b/shape-coerce/src/Data/ShapeCoerce.hs new file mode 100644 index 0000000..f962869 --- /dev/null +++ b/shape-coerce/src/Data/ShapeCoerce.hs @@ -0,0 +1,375 @@ +{-# 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 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 diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index d1e6466..0000000 --- a/stack.yaml +++ /dev/null @@ -1,10 +0,0 @@ -resolver: lts-22.22 -packages: -- domaindriven-core -- domaindriven -- domaindriven-examples - -ghc-options: - "$locals": -fwrite-ide-info - '$everything': -haddock - -hiedir=.hie