add MonadSql, MonadSqlTx

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)
 

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

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

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
+
+-- | 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, 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
+
+class HasSqlBackend a where
+  getSqlBackend :: a -> SqlBackend
+
+instance HasSqlBackend SqlBackend where
+  getSqlBackend = id
+
 type SqlPool = Pool SqlBackend
 
 class HasSqlPool app where

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

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

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