diff --git a/CHANGELOG.md b/CHANGELOG.md index 778b5385..e7dfc37d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,9 @@ -## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.10.2.0...main) +## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.10.3.0...main) + +## [v1.10.3.0](https://github.com/freckle/freckle-app/compare/v1.10.2.0...v1.10.3.0) + +- Add classes `MonadSql` and `MonadSqlTx` for being quite nonspecific about the + context in which you interact with a SQL database. ## [v1.10.2.0](https://github.com/freckle/freckle-app/compare/v1.10.1.0...v1.10.2.0) diff --git a/freckle-app.cabal b/freckle-app.cabal index 3d1c3b52..c61c96a3 100644 --- a/freckle-app.cabal +++ b/freckle-app.cabal @@ -5,7 +5,7 @@ cabal-version: 1.18 -- see: https://github.com/sol/hpack name: freckle-app -version: 1.10.2.0 +version: 1.10.3.0 synopsis: Haskell application toolkit used at Freckle description: Please see README.md category: Utils @@ -35,6 +35,8 @@ library Freckle.App.Bugsnag.MetaData Freckle.App.Csv Freckle.App.Database + Freckle.App.Database.MonadSql + Freckle.App.Database.MonadSqlTx Freckle.App.Database.XRay Freckle.App.Dotenv Freckle.App.Ecs diff --git a/library/Freckle/App.hs b/library/Freckle/App.hs index 080ae787..034f5b3a 100644 --- a/library/Freckle/App.hs +++ b/library/Freckle/App.hs @@ -188,6 +188,7 @@ import Control.Monad.IO.Unlift (MonadUnliftIO (..)) import Control.Monad.Primitive (PrimMonad (..)) import Control.Monad.Reader import Control.Monad.Trans.Resource (MonadResource, ResourceT, runResourceT) +import Database.Persist.Sql (SqlPersistT) import Freckle.App.Database import qualified Freckle.App.Database.XRay as XRay import Freckle.App.OpenTelemetry @@ -251,6 +252,12 @@ instance (Monad m, HasTracer app) => MonadTracer (AppT app m) where instance Applicative m => XRay.MonadTracer (AppT app m) where getVaultData = pure Nothing +instance + (MonadUnliftIO m, HasSqlPool app, HasStatsClient app) + => MonadSqlTx (SqlPersistT (AppT app m)) (AppT app m) + where + runSqlTx = XRay.runDB + runAppT :: (MonadUnliftIO m, HasLogger app) => AppT app m a -> app -> m a runAppT action app = runResourceT $ runLoggerLoggingT app $ runReaderT (unAppT action) app diff --git a/library/Freckle/App/Database.hs b/library/Freckle/App/Database.hs index 069b9709..d293a0df 100644 --- a/library/Freckle/App/Database.hs +++ b/library/Freckle/App/Database.hs @@ -4,14 +4,26 @@ -- | Database access for your @App@ module Freckle.App.Database - ( MonadTracer + ( -- * Running transactions + MonadSqlTx (..) + , runDB + , runDBSimple + + -- * Running queries + , MonadSql + , liftSql + + -- * Telemetry + , MonadTracer , HasStatsClient + + -- * Connection pools , HasSqlPool (..) , SqlPool , makePostgresPool , makePostgresPoolWith - , runDB - , runDBSimple + + -- * Setup , PostgresConnectionConf (..) , PostgresPasswordSource (..) , PostgresPassword (..) @@ -48,6 +60,8 @@ import Database.PostgreSQL.Simple , execute ) import Database.PostgreSQL.Simple.SqlQQ (sql) +import Freckle.App.Database.MonadSql +import Freckle.App.Database.MonadSqlTx import Freckle.App.Env (Timeout (..)) import qualified Freckle.App.Env as Env import Freckle.App.OpenTelemetry diff --git a/library/Freckle/App/Database/MonadSql.hs b/library/Freckle/App/Database/MonadSql.hs new file mode 100644 index 00000000..313f5d72 --- /dev/null +++ b/library/Freckle/App/Database/MonadSql.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FunctionalDependencies #-} + +module Freckle.App.Database.MonadSql + ( MonadSql + , MonadSqlBackend (..) + , liftSql + ) where + +import Freckle.App.Prelude hiding (lift) + +import Control.Monad.Reader (ReaderT (ReaderT), ask) +import Database.Persist.Sql + +-- | A monadic context in which a Persistent backend is available +-- for running database queries +-- +-- The type parameter @backend@ is the Persistent backend. When the +-- backend is 'SqlBackend', you probably want to use the 'MonadSql' +-- alias rather than refer to this class directly. +class MonadSqlBackend backend m | m -> backend where + getSqlBackend :: m backend + +-- | A monadic context in which a SQL backend is available +-- for running database queries +type MonadSql = MonadSqlBackend SqlBackend + +instance Monad m => MonadSqlBackend backend (ReaderT backend m) where + getSqlBackend = ask + +-- | Can be used e.g. to generalized from 'SqlPersistT' to 'MonadSql' +liftSql :: (Monad m, MonadSqlBackend backend m) => ReaderT backend m a -> m a +liftSql (ReaderT f) = getSqlBackend >>= f diff --git a/library/Freckle/App/Database/MonadSqlTx.hs b/library/Freckle/App/Database/MonadSqlTx.hs new file mode 100644 index 00000000..106362de --- /dev/null +++ b/library/Freckle/App/Database/MonadSqlTx.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FunctionalDependencies #-} + +module Freckle.App.Database.MonadSqlTx + ( MonadSqlTx (..) + ) where + +import Freckle.App.Prelude + +-- | A monadic context in which database transactions can be run +-- +-- Type parameters: +-- +-- * @m@ - Generally something like 'ReaderT' where the reader context +-- includes a database connection pool. +-- * @db@ - Generally something like 'ReaderT' where the context includes a +-- database connection. Will typically be an instance of +-- 'Freckle.App.Database.MonadSql.MonadSql'. +class MonadSqlTx db m | m -> db where + -- | Runs the action in a SQL transaction + runSqlTx :: HasCallStack => db a -> m a diff --git a/library/Freckle/App/Database/XRay.hs b/library/Freckle/App/Database/XRay.hs index d5dee7ff..453c06c4 100644 --- a/library/Freckle/App/Database/XRay.hs +++ b/library/Freckle/App/Database/XRay.hs @@ -3,14 +3,26 @@ -- | Legacy version of "Freckle.App.Database" that still uses XRay module Freckle.App.Database.XRay - ( MonadTracer (..) + ( -- * Running transactions + MonadSqlTx (..) + , runDB + , runDBSimple + + -- * Running queries + , MonadSql + , liftSql + + -- * Telemetry + , MonadTracer (..) , HasStatsClient + + -- * Connection pools , HasSqlPool (..) , SqlPool , makePostgresPool , makePostgresPoolWith - , runDB - , runDBSimple + + -- * Setup , PostgresConnectionConf (..) , PostgresPasswordSource (..) , PostgresPassword (..) diff --git a/library/Freckle/App/Test.hs b/library/Freckle/App/Test.hs index 38019552..42d17d01 100644 --- a/library/Freckle/App/Test.hs +++ b/library/Freckle/App/Test.hs @@ -45,7 +45,11 @@ import Control.Monad.Random (MonadRandom (..)) import Control.Monad.Reader import Control.Monad.Trans.Control import Database.Persist.Sql (SqlPersistT, runSqlPool) -import Freckle.App.Database (HasSqlPool (..)) +import Freckle.App.Database + ( HasSqlPool (..) + , HasStatsClient + , MonadSqlTx (..) + ) import qualified Freckle.App.Database.XRay as XRay import qualified Freckle.App.Dotenv as Dotenv import Freckle.App.OpenTelemetry @@ -125,6 +129,12 @@ instance HasTracer app => MonadTracer (AppExample app) where instance XRay.MonadTracer (AppExample app) where getVaultData = pure Nothing +instance + (HasSqlPool app, HasStatsClient app) + => MonadSqlTx (SqlPersistT (AppExample app)) (AppExample app) + where + runSqlTx = XRay.runDB + -- | A type restricted version of id -- -- Like 'example', which forces the expectation to 'IO', this can be used to diff --git a/package.yaml b/package.yaml index a7998fdc..3f028725 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: freckle-app -version: 1.10.2.0 +version: 1.10.3.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app