persistent-eventsource (empty) → 0.2.0

raw patch · 12 files changed

+495/−0 lines, 12 filesdep +basedep +esqueletodep +monad-logger

Dependencies added: base, esqueleto, monad-logger, persistent, persistent-eventsource, persistent-mtl, tasty, tasty-hunit, tasty-quickcheck, text, time, unliftio-core

Files

• Changelog.md +14/−0
• LICENSE +21/−0
• Readme.md +35/−0
• persistent-eventsource.cabal +115/−0
• src/Database/Esqueleto/Monad/Experimental.hs +38/−0
• src/Database/Esqueleto/Monad/Legacy.hs +81/−0
• src/Persistent/EventSource.hs +32/−0
• src/Persistent/EventSource/Aggregate.hs +25/−0
• src/Persistent/EventSource/EventStore.hs +23/−0
• src/Persistent/EventSource/EventStore/Default.hs +57/−0
• src/Persistent/EventSource/Projection.hs +16/−0
• test/Test.hs +38/−0

@@ -0,0 +1,14 @@+# Change log for persistent-eventsource project++## Version 0.2.0 +++ rename persistent-event-source to persistent-eventsource++## Version 0.1.0 +++ Add initial interface++## Version 0.0.0 ++import [template](https://github.com/jappeace/template).+

@@ -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.

@@ -0,0 +1,35 @@+[![Githbu actions build status](https://img.shields.io/github/workflow/status/jappeace/persistent-eventsource/Test)](https://github.com/jappeace/persistent-eventsource/actions)+[![Hackage version](https://img.shields.io/hackage/v/template.svg?label=Hackage)](https://hackage.haskell.org/package/persistent-eventsource) ++Persistent based event sourcing.++TODO:+++ [x] 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+```

@@ -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-eventsource+version:        0.2.0+synopsis:       Persistent based event sourcing.+description:    Event source library for persistent databases.+category:       Database+homepage:       https://github.com/jappeace/persistent-eventsource#readme+bug-reports:    https://github.com/jappeace/persistent-eventsource/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-eventsource++library+  exposed-modules:+      Database.Esqueleto.Monad.Experimental+      Database.Esqueleto.Monad.Legacy+      Persistent.EventSource+      Persistent.EventSource.Aggregate+      Persistent.EventSource.EventStore+      Persistent.EventSource.EventStore.Default+      Persistent.EventSource.Projection+  other-modules:+      Paths_persistent_eventsource+  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_eventsource+  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-eventsource+    , persistent-mtl+    , tasty+    , tasty-hunit+    , tasty-quickcheck+    , text+    , time+    , unliftio-core+  default-language: Haskell2010

@@ -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+  )

@@ -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)

@@ -0,0 +1,32 @@+module Persistent.EventSource+  ( handleCmdWithAuthor+  , applyEventsSince+  , module X+  )+where++import Persistent.EventSource.Projection as X+import Persistent.EventSource.Aggregate as X+import Persistent.EventSource.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

@@ -0,0 +1,25 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilyDependencies #-}++module Persistent.EventSource.Aggregate where++import Database.Persist.Monad (MonadSqlQuery)+import Persistent.EventSource.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]

@@ -0,0 +1,23 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilyDependencies #-}++module Persistent.EventSource.EventStore where++import Persistent.EventSource.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)]+

@@ -0,0 +1,57 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleContexts #-}++module Persistent.EventSource.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

@@ -0,0 +1,16 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilyDependencies #-}+module Persistent.EventSource.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 ()

@@ -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.EventSource()++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+  ]