From 44294102a2aebc75fe198cfd2cdb15179877d4f8 Mon Sep 17 00:00:00 2001 From: Chris Martin Date: Tue, 31 Oct 2023 16:22:11 -0600 Subject: [PATCH 1/2] add MonadSql, MonadSqlTx --- CHANGELOG.md | 7 ++++- freckle-app.cabal | 2 +- library/Freckle/App.hs | 6 ++++ library/Freckle/App/Database.hs | 47 ++++++++++++++++++++++++++-- library/Freckle/App/Database/XRay.hs | 27 ++++++++++------ library/Freckle/App/Test.hs | 13 +++++++- package.yaml | 2 +- 7 files changed, 88 insertions(+), 16 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 778b5385..dc15d9b9 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 `MonadSqlBackend` 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..ab876164 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 diff --git a/library/Freckle/App.hs b/library/Freckle/App.hs index 080ae787..c1a3cfc8 100644 --- a/library/Freckle/App.hs +++ b/library/Freckle/App.hs @@ -251,6 +251,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, HasTracer app) + => MonadSqlTx (ReaderT SqlBackend (AppT app m)) (AppT app m) + where + runSqlTx = 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..6af9afa7 100644 --- a/library/Freckle/App/Database.hs +++ b/library/Freckle/App/Database.hs @@ -1,17 +1,32 @@ {-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeOperators #-} -- | Database access for your @App@ module Freckle.App.Database - ( MonadTracer + ( -- * Running transactions + MonadSqlTx (..) + , runDB + , runDBSimple + + -- * Running queries + , SqlBackend + , HasSqlBackend (..) + , MonadSqlBackend (..) + , liftSql + + -- * Telemetry + , MonadTracer , HasStatsClient + + -- * Connection pools , HasSqlPool (..) , SqlPool , makePostgresPool , makePostgresPoolWith - , runDB - , runDBSimple + + -- * Setup , PostgresConnectionConf (..) , PostgresPasswordSource (..) , PostgresPassword (..) @@ -60,6 +75,32 @@ import UnliftIO.Exception (displayException) import UnliftIO.IORef import Yesod.Core.Types (HandlerData (..), RunHandlerEnv (..)) +-- | A monadic context in which a SQL backend is available +-- for running database queries +class MonadIO m => MonadSqlBackend m where + getSqlBackendM :: m SqlBackend + +instance (HasSqlBackend r, MonadIO m) => MonadSqlBackend (ReaderT r m) where + getSqlBackendM = asks getSqlBackend + +-- | Can be used e.g. to generalized from 'SqlPersistT' to 'MonadSqlBackend' +liftSql :: MonadSqlBackend m => ReaderT SqlBackend m a -> m a +liftSql (ReaderT f) = getSqlBackendM >>= f + +-- | The constraint @'MonadSqlTx' db m@ indicates that @m@ is a monadic +-- context that can run @db@ actions within a SQL transaction. +-- Typically this means that @m@ has access to a connection pool and +-- @db@ has access to a connection. +class (MonadSqlBackend db, MonadUnliftIO m) => MonadSqlTx db m | m -> db where + -- | Runs the action in a SQL transaction + runSqlTx :: HasCallStack => db a -> m a + +class HasSqlBackend a where + getSqlBackend :: a -> SqlBackend + +instance HasSqlBackend SqlBackend where + getSqlBackend = id + type SqlPool = Pool SqlBackend class HasSqlPool app where diff --git a/library/Freckle/App/Database/XRay.hs b/library/Freckle/App/Database/XRay.hs index d5dee7ff..52cee656 100644 --- a/library/Freckle/App/Database/XRay.hs +++ b/library/Freckle/App/Database/XRay.hs @@ -3,14 +3,28 @@ -- | Legacy version of "Freckle.App.Database" that still uses XRay module Freckle.App.Database.XRay - ( MonadTracer (..) + ( -- * Running transactions + MonadSqlTx (..) + , runDB + , runDBSimple + + -- * Running queries + , SqlBackend + , HasSqlBackend (..) + , MonadSqlBackend (..) + , liftSql + + -- * Telemetry + , MonadTracer (..) , HasStatsClient + + -- * Connection pools , HasSqlPool (..) , SqlPool , makePostgresPool , makePostgresPoolWith - , runDB - , runDBSimple + + -- * Setup , PostgresConnectionConf (..) , PostgresPasswordSource (..) , PostgresPassword (..) @@ -25,12 +39,7 @@ import Freckle.App.Prelude import Control.Monad.IO.Unlift (MonadUnliftIO (..)) import Control.Monad.Reader import Data.Pool -import Database.Persist.Postgresql - ( SqlBackend - , SqlPersistT - , runSqlConn - , runSqlPool - ) +import Database.Persist.Postgresql (SqlPersistT, runSqlConn, runSqlPool) import Freckle.App.Database hiding (MonadTracer, runDB) import qualified Freckle.App.Stats as Stats import Network.AWS.XRayClient.Persistent diff --git a/library/Freckle/App/Test.hs b/library/Freckle/App/Test.hs index 38019552..7fd99901 100644 --- a/library/Freckle/App/Test.hs +++ b/library/Freckle/App/Test.hs @@ -45,7 +45,12 @@ 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 (..) + , runDB + ) import qualified Freckle.App.Database.XRay as XRay import qualified Freckle.App.Dotenv as Dotenv import Freckle.App.OpenTelemetry @@ -125,6 +130,12 @@ instance HasTracer app => MonadTracer (AppExample app) where instance XRay.MonadTracer (AppExample app) where getVaultData = pure Nothing +instance + (HasSqlPool app, HasStatsClient app, HasTracer app) + => MonadSqlTx (SqlPersistT (AppExample app)) (AppExample app) + where + runSqlTx = 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 From 130c34b7e8a4cb67ea5a39fdf5b16d8f2c422166 Mon Sep 17 00:00:00 2001 From: Chris Martin Date: Wed, 1 Nov 2023 10:15:00 -0600 Subject: [PATCH 2/2] pat's doc improvements --- library/Freckle/App/Database.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/library/Freckle/App/Database.hs b/library/Freckle/App/Database.hs index 6af9afa7..0359e0a7 100644 --- a/library/Freckle/App/Database.hs +++ b/library/Freckle/App/Database.hs @@ -83,14 +83,14 @@ class MonadIO m => MonadSqlBackend m where instance (HasSqlBackend r, MonadIO m) => MonadSqlBackend (ReaderT r m) where getSqlBackendM = asks getSqlBackend --- | Can be used e.g. to generalized from 'SqlPersistT' to 'MonadSqlBackend' +-- | Generalize from 'SqlPersistT' to 'MonadSqlBackend' liftSql :: MonadSqlBackend m => ReaderT SqlBackend m a -> m a liftSql (ReaderT f) = getSqlBackendM >>= f -- | The constraint @'MonadSqlTx' db m@ indicates that @m@ is a monadic --- context that can run @db@ actions within a SQL transaction. --- Typically this means that @m@ has access to a connection pool and --- @db@ has access to a connection. +-- context that can run @db@ actions, usually as a SQL transaction. +-- Typically, this means that @db@ needs a connection and @m@ can +-- provide one, e.g. from a connection pool. class (MonadSqlBackend db, MonadUnliftIO m) => MonadSqlTx db m | m -> db where -- | Runs the action in a SQL transaction runSqlTx :: HasCallStack => db a -> m a