diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,19 @@ +Copyright (c) 2016-2017 David Reaver + +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,1 @@ +# Eventful postgresql diff --git a/eventful-postgresql.cabal b/eventful-postgresql.cabal new file mode 100644 --- /dev/null +++ b/eventful-postgresql.cabal @@ -0,0 +1,88 @@ +-- This file has been generated from package.yaml by hpack version 0.17.0. +-- +-- see: https://github.com/sol/hpack + +name: eventful-postgresql +version: 0.1.0 +synopsis: Postgres implementations for eventful +description: Postgres implementations for eventful +category: Database,Eventsourcing,PostgreSQL +stability: experimental +maintainer: David Reaver +license: MIT +license-file: LICENSE.md +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + CHANGELOG.md + README.md + +library + hs-source-dirs: + src + default-extensions: ConstraintKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies + ghc-options: -Wall + build-depends: + base >= 4.9 && < 5 + , eventful-core + , eventful-sql-common + , aeson + , bytestring + , mtl + , persistent + , persistent-postgresql + , text + exposed-modules: + Eventful.Store.Postgresql + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + tests + src + default-extensions: ConstraintKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies + ghc-options: -Wall + build-depends: + base >= 4.9 && < 5 + , eventful-core + , eventful-sql-common + , aeson + , bytestring + , mtl + , persistent + , persistent-postgresql + , text + , hspec + , HUnit + , eventful-test-helpers + other-modules: + Eventful.Store.PostgresqlSpec + HLint + Eventful.Store.Postgresql + default-language: Haskell2010 + +test-suite style + type: exitcode-stdio-1.0 + main-is: HLint.hs + hs-source-dirs: + tests + default-extensions: ConstraintKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies + ghc-options: -Wall + build-depends: + base >= 4.9 && < 5 + , eventful-core + , eventful-sql-common + , aeson + , bytestring + , mtl + , persistent + , persistent-postgresql + , text + , hlint + other-modules: + Eventful.Store.PostgresqlSpec + Spec + default-language: Haskell2010 diff --git a/src/Eventful/Store/Postgresql.hs b/src/Eventful/Store/Postgresql.hs new file mode 100644 --- /dev/null +++ b/src/Eventful/Store/Postgresql.hs @@ -0,0 +1,44 @@ +-- | Defines an Postgresql event store. + +module Eventful.Store.Postgresql + ( postgresqlEventStore + , initializePostgresqlEventStore + , module Eventful.Store.Class + , module Eventful.Store.Sql + ) where + +import Control.Monad.Reader +import Data.Monoid ((<>)) +import Data.Text (Text) +import Database.Persist +import Database.Persist.Sql + +import Eventful.Store.Class +import Eventful.Store.Sql + +-- | An 'EventStore' that uses a PostgreSQL database as a backend. Use +-- 'SqlEventStoreConfig' to configure this event store. +postgresqlEventStore + :: (MonadIO m, PersistEntity entity, PersistEntityBackend entity ~ SqlBackend) + => SqlEventStoreConfig entity serialized + -> EventStore serialized (SqlPersistT m) +postgresqlEventStore config = + let + getLatestVersion = sqlMaxEventVersion config maxPostgresVersionSql + getEvents = sqlGetAggregateEvents config + storeEvents' = sqlStoreEvents config maxPostgresVersionSql + storeEvents = transactionalExpectedWriteHelper getLatestVersion storeEvents' + in EventStore{..} + +maxPostgresVersionSql :: DBName -> DBName -> DBName -> Text +maxPostgresVersionSql (DBName tableName) (DBName uuidFieldName) (DBName versionFieldName) = + "SELECT COALESCE(MAX(" <> versionFieldName <> "), -1) FROM " <> tableName <> " WHERE " <> uuidFieldName <> " = ?" + +-- | This function runs migrations to create the events table if it isn't +-- present. +initializePostgresqlEventStore :: (MonadIO m) => ConnectionPool -> m () +initializePostgresqlEventStore pool = do + -- Run migrations + _ <- liftIO $ runSqlPool (runMigrationSilent migrateSqlEvent) pool + + return () diff --git a/tests/Eventful/Store/PostgresqlSpec.hs b/tests/Eventful/Store/PostgresqlSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Eventful/Store/PostgresqlSpec.hs @@ -0,0 +1,58 @@ +module Eventful.Store.PostgresqlSpec (spec) where + +import Control.Monad.Reader (ask) +import Data.Monoid ((<>)) +import Data.Text (Text, intercalate) +import Database.Persist.Postgresql +import Test.Hspec + +import Eventful.Serializer +import Eventful.Store.Postgresql +import Eventful.TestHelpers + +makeStore :: (MonadIO m) => m (EventStore CounterEvent (SqlPersistT m), ConnectionPool) +makeStore = do + -- TODO: Obviously this is hard-coded, make this use environment variables or + -- something in the future. + let + connString = "host=localhost port=5432 user=postgres dbname=eventful_test password=password" + store = postgresqlEventStore defaultSqlEventStoreConfig + store' = serializedEventStore jsonStringSerializer store + pool <- liftIO $ runNoLoggingT (createPostgresqlPool connString 1) + initializePostgresqlEventStore pool + liftIO $ runSqlPool truncateTables pool + return (store', pool) + +getTables :: MonadIO m => SqlPersistT m [Text] +getTables = do + tables <- + rawSql + "SELECT table_name FROM information_schema.tables WHERE table_schema = 'public' AND table_type = 'BASE TABLE';" + [] + return $ map unSingle tables + +truncateTables :: MonadIO m => SqlPersistT m () +truncateTables = do + tables <- getTables + sqlBackend <- ask + let + escapedTables = map (connEscapeName sqlBackend . DBName) tables + query = "TRUNCATE TABLE " <> intercalate ", " escapedTables <> " RESTART IDENTITY CASCADE" + rawExecute query [] + +makeGlobalStore + :: (MonadIO m) + => m (EventStore CounterEvent (SqlPersistT m), GloballyOrderedEventStore CounterEvent (SqlPersistT m), ConnectionPool) +makeGlobalStore = do + (store, pool) <- makeStore + let + globalStore = sqlGloballyOrderedEventStore defaultSqlEventStoreConfig + globalStore' = serializedGloballyOrderedEventStore jsonStringSerializer globalStore + return (store, globalStore', pool) + + +spec :: Spec +spec = do + describe "Postgresql event store" $ do + eventStoreSpec makeStore (flip runSqlPool) + sequencedEventStoreSpec makeGlobalStore (flip runSqlPool) diff --git a/tests/HLint.hs b/tests/HLint.hs new file mode 100644 --- /dev/null +++ b/tests/HLint.hs @@ -0,0 +1,19 @@ +module Main (main) where + +import Language.Haskell.HLint (hlint) +import System.Exit (exitFailure, exitSuccess) + +import Prelude (String, IO, null) + +arguments :: [String] +arguments = + [ "src" + , "tests" + , "-i=Redundant do" + , "-i=Unused LANGUAGE pragma" -- This fails on DeriveGeneric + ] + +main :: IO () +main = do + hints <- hlint arguments + if null hints then exitSuccess else exitFailure diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}