{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- | Defines an Sqlite event store.
module Eventium.Store.Sqlite
  ( sqliteEventStoreWriter,
    initializeSqliteEventStore,
    module Eventium.Store.Class,
    module Eventium.Store.Sql,
  )
where

import Control.Monad.Reader
import Data.Text (Text)
import Database.Persist
import Database.Persist.Class (SafeToInsert)
import Database.Persist.Names (EntityNameDB (..), FieldNameDB (..))
import Database.Persist.Sql
import Eventium.Store.Class
import Eventium.Store.Sql

-- | An 'EventStoreWriter' that uses an SQLite database as a backend. Use
-- 'SqlEventStoreConfig' to configure this event store.
sqliteEventStoreWriter ::
  (MonadIO m, PersistEntity entity, PersistEntityBackend entity ~ SqlBackend, SafeToInsert entity) =>
  SqlEventStoreConfig entity serialized ->
  VersionedEventStoreWriter (SqlPersistT m) serialized
sqliteEventStoreWriter :: forall (m :: * -> *) entity serialized.
(MonadIO m, PersistEntity entity,
 PersistEntityBackend entity ~ SqlBackend, SafeToInsert entity) =>
SqlEventStoreConfig entity serialized
-> VersionedEventStoreWriter (SqlPersistT m) serialized
sqliteEventStoreWriter SqlEventStoreConfig entity serialized
config = (UUID
 -> ExpectedPosition EventVersion
 -> [serialized]
 -> SqlPersistT
      m (Either (EventWriteError EventVersion) EventVersion))
-> EventStoreWriter
     UUID EventVersion (ReaderT SqlBackend m) serialized
forall key position (m :: * -> *) event.
(key
 -> ExpectedPosition position
 -> [event]
 -> m (Either (EventWriteError position) EventVersion))
-> EventStoreWriter key position m event
EventStoreWriter ((UUID
  -> ExpectedPosition EventVersion
  -> [serialized]
  -> SqlPersistT
       m (Either (EventWriteError EventVersion) EventVersion))
 -> EventStoreWriter
      UUID EventVersion (ReaderT SqlBackend m) serialized)
-> (UUID
    -> ExpectedPosition EventVersion
    -> [serialized]
    -> SqlPersistT
         m (Either (EventWriteError EventVersion) EventVersion))
-> EventStoreWriter
     UUID EventVersion (ReaderT SqlBackend m) serialized
forall a b. (a -> b) -> a -> b
$ (UUID -> ReaderT SqlBackend m EventVersion)
-> (UUID -> [serialized] -> ReaderT SqlBackend m EventVersion)
-> UUID
-> ExpectedPosition EventVersion
-> [serialized]
-> SqlPersistT
     m (Either (EventWriteError EventVersion) EventVersion)
forall (m :: * -> *) position key event.
(Monad m, Ord position, Num position) =>
(key -> m position)
-> (key -> [event] -> m EventVersion)
-> key
-> ExpectedPosition position
-> [event]
-> m (Either (EventWriteError position) EventVersion)
transactionalExpectedWriteHelper UUID -> ReaderT SqlBackend m EventVersion
getLatestVersion UUID -> [serialized] -> ReaderT SqlBackend m EventVersion
storeEvents'
  where
    getLatestVersion :: UUID -> ReaderT SqlBackend m EventVersion
getLatestVersion = SqlEventStoreConfig entity serialized
-> (FieldNameDB -> FieldNameDB -> FieldNameDB -> Text)
-> UUID
-> ReaderT SqlBackend m EventVersion
forall (m :: * -> *) entity serialized.
(MonadIO m, PersistEntity entity,
 PersistEntityBackend entity ~ SqlBackend) =>
SqlEventStoreConfig entity serialized
-> (FieldNameDB -> FieldNameDB -> FieldNameDB -> Text)
-> UUID
-> SqlPersistT m EventVersion
sqlMaxEventVersion SqlEventStoreConfig entity serialized
config FieldNameDB -> FieldNameDB -> FieldNameDB -> Text
maxSqliteVersionSql
    storeEvents' :: UUID -> [serialized] -> ReaderT SqlBackend m EventVersion
storeEvents' = SqlEventStoreConfig entity serialized
-> Maybe (Text -> Text)
-> (FieldNameDB -> FieldNameDB -> FieldNameDB -> Text)
-> UUID
-> [serialized]
-> ReaderT SqlBackend m EventVersion
forall (m :: * -> *) entity serialized.
(MonadIO m, PersistEntity entity,
 PersistEntityBackend entity ~ SqlBackend, SafeToInsert entity) =>
SqlEventStoreConfig entity serialized
-> Maybe (Text -> Text)
-> (FieldNameDB -> FieldNameDB -> FieldNameDB -> Text)
-> UUID
-> [serialized]
-> SqlPersistT m EventVersion
sqlStoreEvents SqlEventStoreConfig entity serialized
config Maybe (Text -> Text)
forall a. Maybe a
Nothing FieldNameDB -> FieldNameDB -> FieldNameDB -> Text
maxSqliteVersionSql

maxSqliteVersionSql :: FieldNameDB -> FieldNameDB -> FieldNameDB -> Text
maxSqliteVersionSql :: FieldNameDB -> FieldNameDB -> FieldNameDB -> Text
maxSqliteVersionSql (FieldNameDB Text
tableName) (FieldNameDB Text
uuidFieldName) (FieldNameDB Text
versionFieldName) =
  Text
"SELECT IFNULL(MAX(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
versionFieldName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"), -1) FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uuidFieldName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ?"

-- | This functions runs the migrations required to create the events table and
-- also adds an index on the UUID column.
initializeSqliteEventStore ::
  (MonadIO m, PersistEntity entity, PersistEntityBackend entity ~ SqlBackend) =>
  SqlEventStoreConfig entity serialized ->
  ConnectionPool ->
  m ()
initializeSqliteEventStore :: forall (m :: * -> *) entity serialized.
(MonadIO m, PersistEntity entity,
 PersistEntityBackend entity ~ SqlBackend) =>
SqlEventStoreConfig entity serialized -> ConnectionPool -> m ()
initializeSqliteEventStore SqlEventStoreConfig {EntityField entity serialized
EntityField entity UUID
EntityField entity EventVersion
EntityField entity (Key entity)
entity -> serialized
entity -> UUID
entity -> EventVersion
UUID -> EventVersion -> serialized -> entity
SequenceNumber -> Key entity
Key entity -> SequenceNumber
sqlEventStoreConfigSequenceMakeEntity :: UUID -> EventVersion -> serialized -> entity
sqlEventStoreConfigMakeKey :: SequenceNumber -> Key entity
sqlEventStoreConfigUnKey :: Key entity -> SequenceNumber
sqlEventStoreConfigUUID :: entity -> UUID
sqlEventStoreConfigVersion :: entity -> EventVersion
sqlEventStoreConfigData :: entity -> serialized
sqlEventStoreConfigSequenceNumberField :: EntityField entity (Key entity)
sqlEventStoreConfigUUIDField :: EntityField entity UUID
sqlEventStoreConfigVersionField :: EntityField entity EventVersion
sqlEventStoreConfigDataField :: EntityField entity serialized
sqlEventStoreConfigDataField :: forall entity serialized.
SqlEventStoreConfig entity serialized
-> EntityField entity serialized
sqlEventStoreConfigVersionField :: forall entity serialized.
SqlEventStoreConfig entity serialized
-> EntityField entity EventVersion
sqlEventStoreConfigUUIDField :: forall entity serialized.
SqlEventStoreConfig entity serialized -> EntityField entity UUID
sqlEventStoreConfigSequenceNumberField :: forall entity serialized.
SqlEventStoreConfig entity serialized
-> EntityField entity (Key entity)
sqlEventStoreConfigData :: forall entity serialized.
SqlEventStoreConfig entity serialized -> entity -> serialized
sqlEventStoreConfigVersion :: forall entity serialized.
SqlEventStoreConfig entity serialized -> entity -> EventVersion
sqlEventStoreConfigUUID :: forall entity serialized.
SqlEventStoreConfig entity serialized -> entity -> UUID
sqlEventStoreConfigUnKey :: forall entity serialized.
SqlEventStoreConfig entity serialized
-> Key entity -> SequenceNumber
sqlEventStoreConfigMakeKey :: forall entity serialized.
SqlEventStoreConfig entity serialized
-> SequenceNumber -> Key entity
sqlEventStoreConfigSequenceMakeEntity :: forall entity serialized.
SqlEventStoreConfig entity serialized
-> UUID -> EventVersion -> serialized -> entity
..} ConnectionPool
pool = do
  -- Run migrations
  [Text]
_ <- IO [Text] -> m [Text]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Text] -> m [Text]) -> IO [Text] -> m [Text]
forall a b. (a -> b) -> a -> b
$ ReaderT SqlBackend IO [Text] -> ConnectionPool -> IO [Text]
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> m a
runSqlPool (Migration -> ReaderT SqlBackend IO [Text]
forall (m :: * -> *).
MonadUnliftIO m =>
Migration -> ReaderT SqlBackend m [Text]
runMigrationSilent Migration
migrateSqlEvent) ConnectionPool
pool

  -- Create index on uuid field so retrieval is very fast
  let tableName :: Text
tableName = EntityNameDB -> Text
unEntityNameDB (EntityNameDB -> Text) -> EntityNameDB -> Text
forall a b. (a -> b) -> a -> b
$ entity -> EntityNameDB
forall record. PersistEntity record => record -> EntityNameDB
tableDBName (UUID -> EventVersion -> serialized -> entity
sqlEventStoreConfigSequenceMakeEntity UUID
forall a. HasCallStack => a
undefined EventVersion
forall a. HasCallStack => a
undefined serialized
forall a. HasCallStack => a
undefined)
      uuidFieldName :: Text
uuidFieldName = FieldNameDB -> Text
unFieldNameDB (FieldNameDB -> Text) -> FieldNameDB -> Text
forall a b. (a -> b) -> a -> b
$ EntityField entity (Key entity) -> FieldNameDB
forall record typ.
PersistEntity record =>
EntityField record typ -> FieldNameDB
fieldDBName EntityField entity (Key entity)
sqlEventStoreConfigSequenceNumberField
      indexSql :: Text
indexSql =
        Text
"CREATE INDEX IF NOT EXISTS "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uuidFieldName
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_index"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ON "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ("
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uuidFieldName
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (ReaderT SqlBackend IO () -> ConnectionPool -> IO ())
-> ConnectionPool -> ReaderT SqlBackend IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT SqlBackend IO () -> ConnectionPool -> IO ()
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> m a
runSqlPool ConnectionPool
pool (ReaderT SqlBackend IO () -> IO ())
-> ReaderT SqlBackend IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [PersistValue] -> ReaderT SqlBackend IO ()
forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m ()
rawExecute Text
indexSql []

  () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()