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 `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)
 

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

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

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

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

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

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 (..)

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

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