checkpoint in liftSql (#138)

freckle · Dec 7, 2023 · 360bd4d · 360bd4d
1 parent 168b032
commit 360bd4d
Show file tree

Hide file tree

Showing 5 changed files with 14 additions and 8 deletions.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -1,4 +1,9 @@
-## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.10.8.0...main)
+## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.11.0.0...main)
+
+## [v1.11.0.0](https://github.com/freckle/freckle-app/compare/v1.10.8.0...v1.11.0.0)
+
+- Add `MonadUnliftIO` superclass to `MonadSqlBackend`
+- Use `checkpointCallStack` in `liftSql` to help grab more stack frames
 
 ## [v1.10.8.0](https://github.com/freckle/freckle-app/compare/v1.10.7.0...v1.10.8.0)
 

diff --git 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.8.0
+version:        1.11.0.0
 synopsis:       Haskell application toolkit used at Freckle
 description:    Please see README.md
 category:       Utils

diff --git a/library/Freckle/App/Database.hs b/library/Freckle/App/Database.hs
@@ -65,6 +65,7 @@ import Database.PostgreSQL.Simple
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Freckle.App.Env (Timeout (..))
 import qualified Freckle.App.Env as Env
+import Freckle.App.Exception.MonadUnliftIO
 import Freckle.App.OpenTelemetry
 import Freckle.App.Stats (HasStatsClient)
 import qualified Freckle.App.Stats as Stats
@@ -76,15 +77,15 @@ 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
+class MonadUnliftIO m => MonadSqlBackend m where
   getSqlBackendM :: m SqlBackend
 
-instance (HasSqlBackend r, MonadIO m) => MonadSqlBackend (ReaderT r m) where
+instance (HasSqlBackend r, MonadUnliftIO 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
+liftSql :: (MonadSqlBackend m, HasCallStack) => ReaderT SqlBackend m a -> m a
+liftSql (ReaderT f) = checkpointCallStack $ getSqlBackendM >>= f
 
 -- | The constraint @'MonadSqlTx' db m@ indicates that @m@ is a monadic
 --   context that can run @db@ actions, usually as a SQL transaction.

diff --git a/library/Freckle/App/Test/Yesod.hs b/library/Freckle/App/Test/Yesod.hs
@@ -147,7 +147,7 @@ bodyContains = liftYesodExample . Yesod.Test.bodyContains
 
 -- | Clears the current cookies
 testClearCookies :: forall m site. MonadYesodExample site m => m ()
-testClearCookies = liftYesodExample $ Yesod.Test.testClearCookies
+testClearCookies = liftYesodExample Yesod.Test.testClearCookies
 
 -- | Deletes the cookie of the given name
 testDeleteCookie

diff --git a/package.yaml b/package.yaml
@@ -1,5 +1,5 @@
 name: freckle-app
-version: 1.10.8.0
+version: 1.11.0.0
 maintainer: Freckle Education
 category: Utils
 github: freckle/freckle-app