diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,10 @@ +# Change log for persistent-event-source project + +## Version 0.1.0 + ++ Add initial interface + +## Version 0.0.0 + +import [template](https://github.com/jappeace/template). + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2022 Jappie Klooster + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Readme.md b/Readme.md new file mode 100644 --- /dev/null +++ b/Readme.md @@ -0,0 +1,35 @@ +[![Githbu actions build status](https://img.shields.io/github/workflow/status/jappeace/persistent-event-source/Test)](https://github.com/jappeace/persistent-event-source/actions) +[![Hackage version](https://img.shields.io/hackage/v/template.svg?label=Hackage)](https://hackage.haskell.org/package/persistent-event-source) + +Persistent based event sourcing. + +TODO: + ++ [ ] Add event ordering code. ++ [ ] Prove correctness of event ordering. ++ [ ] I'd like to also add the reapply in a transaction + code, we'd need to refactor so the tables are known + by the system so we can automatically generate a truncate query. ++ [ ] Upstream Database.Esqueleto.* to the right package + +## Usage + +### Tools +Enter the nix shell. +``` +nix-shell +``` +You can checkout the makefile to see what's available: +``` +cat makefile +``` + +### Running +``` +make run +``` + +### Fast filewatch which runs tests +``` +make ghcid +``` diff --git a/persistent-event-source.cabal b/persistent-event-source.cabal new file mode 100644 --- /dev/null +++ b/persistent-event-source.cabal @@ -0,0 +1,115 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.7. +-- +-- see: https://github.com/sol/hpack + +name: persistent-event-source +version: 0.1.0 +synopsis: Persistent based event sourcing. +description: Event source library for persistent databases. +category: Database +homepage: https://github.com/jappeace/persistent-event-source#readme +bug-reports: https://github.com/jappeace/persistent-event-source/issues +author: Jappie Klooster +maintainer: jappieklooster@hotmail.com +copyright: 2023 Jappie Klooster +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + Readme.md + LICENSE + Changelog.md + +source-repository head + type: git + location: https://github.com/jappeace/persistent-event-source + +library + exposed-modules: + Database.Esqueleto.Monad.Experimental + Database.Esqueleto.Monad.Legacy + Persistent.Event.Source + Persistent.Event.Source.Aggregate + Persistent.Event.Source.EventStore + Persistent.Event.Source.EventStore.Default + Persistent.Event.Source.Projection + other-modules: + Paths_persistent_event_source + hs-source-dirs: + src + default-extensions: + EmptyCase + FlexibleContexts + FlexibleInstances + InstanceSigs + MultiParamTypeClasses + LambdaCase + MultiWayIf + NamedFieldPuns + TupleSections + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + GeneralizedNewtypeDeriving + StandaloneDeriving + OverloadedStrings + TypeApplications + ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wincomplete-record-updates -Widentities -Wcpp-undef -fwarn-tabs -Wpartial-fields -fdefer-diagnostics -Wunused-packages + build-depends: + base >=4.7 && <5 + , esqueleto + , monad-logger + , persistent + , persistent-mtl + , text + , time + , unliftio-core + default-language: Haskell2010 + +test-suite unit + type: exitcode-stdio-1.0 + main-is: Test.hs + other-modules: + Paths_persistent_event_source + hs-source-dirs: + test + default-extensions: + EmptyCase + FlexibleContexts + FlexibleInstances + InstanceSigs + MultiParamTypeClasses + LambdaCase + MultiWayIf + NamedFieldPuns + TupleSections + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + GeneralizedNewtypeDeriving + StandaloneDeriving + OverloadedStrings + TypeApplications + ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wincomplete-record-updates -Widentities -Wcpp-undef -fwarn-tabs -Wpartial-fields -fdefer-diagnostics -Wunused-packages -Wno-unused-packages + build-depends: + base >=4.7 && <5 + , esqueleto + , monad-logger + , persistent + , persistent-event-source + , persistent-mtl + , tasty + , tasty-hunit + , tasty-quickcheck + , text + , time + , unliftio-core + default-language: Haskell2010 diff --git a/src/Database/Esqueleto/Monad/Experimental.hs b/src/Database/Esqueleto/Monad/Experimental.hs new file mode 100644 --- /dev/null +++ b/src/Database/Esqueleto/Monad/Experimental.hs @@ -0,0 +1,38 @@ +-- | Classy shim around @Database.Esqueleto.Experimental@ +-- +-- In the style of @Database.Persist.Monad@, this exposes a "classy" +-- (typeclass-using) API for Esqueleto functions, allowing them to be +-- used with 'MonadSqlQuery' constraints rather than a +-- @'ReaderT' 'SqlBackend'@ concrete type. +-- +-- The goal of this module is to be a drop-in replacement for +-- @Database.Esqueleto.Experimental@. +module Database.Esqueleto.Monad.Experimental + ( module Database.Esqueleto.Monad.Legacy + , module Database.Esqueleto.Experimental + ) where + +import Database.Esqueleto.Monad.Legacy hiding + ( From + , from + , on + ) +import Database.Esqueleto.Experimental hiding + ( select + , selectOne + , delete + , update + , deleteWhere + , get + , getBy + , getEntity + , getMany + , insert + , insert_ + , insertKey + , insertMany_ + , insertEntityMany + , selectFirst + , updateWhere + , renderQuerySelect + ) diff --git a/src/Database/Esqueleto/Monad/Legacy.hs b/src/Database/Esqueleto/Monad/Legacy.hs new file mode 100644 --- /dev/null +++ b/src/Database/Esqueleto/Monad/Legacy.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | Classy shim around @Database.Esqueleto.Legacy@ +-- +-- In the style of @Database.Persist.Monad@, this exposes a "classy" +-- (typeclass-using) API for Esqueleto functions, allowing them to be +-- used with 'MonadSqlQuery' constraints rather than a +-- @'ReaderT' 'SqlBackend'@ concrete type. +-- +-- The goal of this module is to be a drop-in replacement for +-- @Database.Esqueleto.Legacy@. +module Database.Esqueleto.Monad.Legacy + ( select + , selectOne + , delete + , update + , renderQuerySelect + , P.deleteWhere + , P.get + , P.getBy + , P.getEntity + , P.getMany + , P.insert + , P.insert_ + , P.insertKey + , P.insertMany_ + , P.insertEntityMany + , P.selectFirst + , P.updateWhere + , module Database.Esqueleto.Legacy + ) where + +import Data.Text(Text) +import Database.Esqueleto.Internal.Internal (SqlSelect) +import qualified Database.Esqueleto.Legacy as E +import Database.Esqueleto.Legacy hiding + ( select + , selectOne + , delete + , update + , renderQuerySelect + + -- Persistent re-exports + , deleteWhere + , get + , getBy + , getEntity + , getMany + , insert + , insert_ + , insertKey + , insertMany_ + , insertEntityMany + , selectFirst + , updateWhere + ) +import qualified Database.Persist.Monad as P + +-- | Classy version of 'E.select' +select :: (P.MonadSqlQuery m, SqlSelect a r) => SqlQuery a -> m [r] +select query = P.unsafeLiftSql "esqueleto-select" (E.select query) + +-- | Classy version of 'E.selectOne' +selectOne :: (P.MonadSqlQuery m, SqlSelect a r) => SqlQuery a -> m (Maybe r) +selectOne query = P.unsafeLiftSql "esqueleto-selectOne" (E.selectOne query) + +-- | Classy version of 'E.delete' +delete :: (P.MonadSqlQuery m) => SqlQuery () -> m () +delete query = P.unsafeLiftSql "esqueleto-delete" (E.delete query) + +-- | Classy version of 'E.update' +update :: + ( P.MonadSqlQuery m + , PersistEntity val + , BackendCompatible SqlBackend (PersistEntityBackend val) + ) + => (SqlExpr (Entity val) -> SqlQuery ()) -> m () +update query = P.unsafeLiftSql "esqueleto-update" (E.update query) + +renderQuerySelect :: (P.MonadSqlQuery m, SqlSelect a r) => SqlQuery a -> m (Text, [PersistValue]) +renderQuerySelect query = P.unsafeLiftSql "esqueleto-renderQuerySelect" (E.renderQuerySelect query) diff --git a/src/Persistent/Event/Source.hs b/src/Persistent/Event/Source.hs new file mode 100644 --- /dev/null +++ b/src/Persistent/Event/Source.hs @@ -0,0 +1,32 @@ +module Persistent.Event.Source + ( handleCmdWithAuthor + , applyEventsSince + , module X + ) +where + +import Persistent.Event.Source.Projection as X +import Persistent.Event.Source.Aggregate as X +import Persistent.Event.Source.EventStore as X +import Database.Persist.Monad(MonadSqlQuery) +import Database.Persist.Class.PersistEntity +import Control.Monad.IO.Unlift +import Control.Monad.Logger +import Data.Foldable + +-- TODO: handle potential concurrency problems, catch errors from invalid commands +-- | Executes command and applies events, as well as storing them, aka `transact` or `actAndApply` +handleCmdWithAuthor :: ( Aggregate a, EventStore a, MonadUnliftIO m, MonadSqlQuery m, MonadLogger m) => + Maybe (Actor a) -> Command a -> m [Entity (Event a)] +handleCmdWithAuthor mAuthorId cmd = do + events <- act mAuthorId cmd + traverse_ apply events + eventIds <- storeMany events + markEventsApplied eventIds + pure $ zipWith Entity eventIds events + +applyEventsSince :: (EventStore a, MonadUnliftIO m, MonadSqlQuery m, MonadLogger m) => Maybe (Key (Event a)) -> m () +applyEventsSince lastEventId = do + events <- loadUnappliedEvents lastEventId + traverse_ (apply . entityVal) events + markEventsApplied $ entityKey <$> events diff --git a/src/Persistent/Event/Source/Aggregate.hs b/src/Persistent/Event/Source/Aggregate.hs new file mode 100644 --- /dev/null +++ b/src/Persistent/Event/Source/Aggregate.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +module Persistent.Event.Source.Aggregate where + +import Database.Persist.Monad (MonadSqlQuery) +import Persistent.Event.Source.Projection +import Control.Monad.IO.Class + +-- | Aggregate is an intermediate step, allowing you to specify how +-- your changeable commands are stored. +-- stored events should be stable like an API. +class Projection a => Aggregate a where + -- | The command is a sumtype with all your possible event sourced + -- actions. + type Command a = cmd | cmd -> a + + -- | allows you to specify who executed a command. + -- for audit purposes. set this to `()` if you don't care about this. + type Actor a + + -- TODO: handle invalid actions + -- | Validate action and generate events, if any. + act :: ( MonadSqlQuery m, MonadIO m ) => + Maybe (Actor a) -> Command a -> m [Event a] diff --git a/src/Persistent/Event/Source/EventStore.hs b/src/Persistent/Event/Source/EventStore.hs new file mode 100644 --- /dev/null +++ b/src/Persistent/Event/Source/EventStore.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +module Persistent.Event.Source.EventStore where + +import Persistent.Event.Source.Projection +import Control.Monad.IO.Unlift +import Database.Persist.Monad(MonadSqlQuery) +import Database.Persist.Class.PersistEntity + +-- | Determines how events are stored and retrieved. +class Projection a => EventStore a where + + storeMany :: (MonadIO m, MonadSqlQuery m) => [Event a] -> m [Key (Event a)] + + -- | Nothing if no last applied event found. + getLastAppliedEventId :: (MonadIO m, MonadSqlQuery m) => m (Maybe (Key (Event a))) + + markEventsApplied :: (MonadIO m, MonadSqlQuery m) => [Key (Event a)] -> m () + + -- | Will load all events on nothing + loadUnappliedEvents :: (MonadIO m, MonadSqlQuery m) => Maybe (Key (Event a)) -> m [Entity (Event a)] + diff --git a/src/Persistent/Event/Source/EventStore/Default.hs b/src/Persistent/Event/Source/EventStore/Default.hs new file mode 100644 --- /dev/null +++ b/src/Persistent/Event/Source/EventStore/Default.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} + +module Persistent.Event.Source.EventStore.Default where + +import qualified Database.Esqueleto.Monad.Experimental as Ex +import Database.Persist.Monad.Class +import Database.Persist.Monad +import Data.Dynamic +import Data.Time +import Control.Monad.IO.Class +import Control.Monad +import Database.Persist.Class(EntityField, PersistField, PersistEntity, PersistRecordBackend) +import Database.Persist.Class.PersistEntity(Entity(..), Key, SelectOpt(..)) +import Database.Persist.Sql(SqlBackend) + +defaultStoreMany :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) => [record] -> m [Key record] +defaultStoreMany = insertMany + +defaultGetLastAppliedEventId :: (PersistEntity record, Typeable record, + MonadSqlQuery m, + Ex.PersistEntityBackend record ~ SqlBackend) => + EntityField record typ -> (record -> b) -> m (Maybe b) +defaultGetLastAppliedEventId sortField extractId = do + lastEvent <- selectFirst [] [Desc sortField] + pure $ (extractId . entityVal) <$> lastEvent + +defaultMarkEventsApplied :: (MonadIO m, PersistEntity record, + Typeable record, + MonadSqlQuery m, + Ex.PersistEntityBackend record ~ SqlBackend) => + (t -> Key record) -> (UTCTime -> t -> record) -> [t] -> m () +defaultMarkEventsApplied toKey toRecord eventIds = do + appliedEvents <- forM eventIds $ \eventId -> do + time' <- liftIO getCurrentTime + pure $ Entity (toKey eventId) $ toRecord time' eventId + insertEntityMany appliedEvents + + +defaultLoadUnappliedEvents :: (Traversable t, + MonadSqlQuery m, + PersistEntity val1, PersistEntity val2, + PersistField a) => + EntityField val1 a -> EntityField val2 a -> t a -> m [Entity val1] +defaultLoadUnappliedEvents eventId appliedId mapplied = do + Ex.select $ do + event <- Ex.from $ Ex.table + void $ forM mapplied $ \applied -> + Ex.where_ $ event Ex.^. eventId Ex.>. Ex.val applied + Ex.where_ $ Ex.notExists $ do + applied <- Ex.from $ Ex.table + Ex.where_ $ event Ex.^. eventId Ex.==. applied Ex.^. appliedId + Ex.orderBy + [ Ex.asc $ event Ex.^. eventId + ] + pure event diff --git a/src/Persistent/Event/Source/Projection.hs b/src/Persistent/Event/Source/Projection.hs new file mode 100644 --- /dev/null +++ b/src/Persistent/Event/Source/Projection.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilyDependencies #-} +module Persistent.Event.Source.Projection where + +import Database.Persist.Monad(MonadSqlQuery) +import Control.Monad.IO.Unlift +import Control.Monad.Logger + +-- | Projection is about setting your event sourced table to +-- data in the event. +class Projection a where + type Event a = ev | ev -> a + + -- | Apply event to this context + -- Intended to have write access to the database for updating views + apply :: (MonadUnliftIO m, MonadLogger m, MonadSqlQuery m) => Event a -> m () diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,38 @@ +module Main where + +import Test.Tasty +import Test.Tasty.QuickCheck as QC +import Test.Tasty.HUnit + +import Data.List(sort) +import qualified Persistent.Event.Source() + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [qcProps, unitTests] + +qcProps :: TestTree +qcProps = testGroup "(checked by QuickCheck)" + [ QC.testProperty "sort == sort . reverse" $ + \list -> sort (list :: [Int]) == sort (reverse list) + , QC.testProperty "Fermat's little theorem" $ + \x -> ((x :: Integer)^zeven - x) `mod` zeven == 0 + ] + where + zeven :: Integer + zeven = 7 + +oneTwoThree :: [Int] +oneTwoThree = [1, 2, 3] + +unitTests :: TestTree +unitTests = testGroup "Unit tests" + [ testCase "List comparison (different length)" $ + oneTwoThree `compare` [1,2] @?= GT + + -- the following test does not hold + , testCase "List comparison (same length)" $ + oneTwoThree `compare` [1,2,3] @?= EQ + ]