freckle-app 1.10.2.0 → 1.10.3.0
raw patch · 8 files changed
+113/−21 lines, 8 files
Files
- CHANGELOG.md +6/−1
- freckle-app.cabal +1/−1
- library/Freckle/App.hs +6/−0
- library/Freckle/App/Database.hs +44/−3
- library/Freckle/App/Database/XRay.hs +18/−9
- library/Freckle/App/Env.hs +25/−5
- library/Freckle/App/Test.hs +12/−1
- package.yaml +1/−1
CHANGELOG.md view
@@ -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 view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: freckle-app-version: 1.10.2.0+version: 1.10.3.0 license: MIT license-file: LICENSE maintainer: Freckle Education
library/Freckle/App.hs view
@@ -251,6 +251,12 @@ 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 view
@@ -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 (..)@@ -59,6 +74,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
library/Freckle/App/Database/XRay.hs view
@@ -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 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/Env.hs view
@@ -33,6 +33,8 @@ , eitherReader , time , keyValues+ , keyValue+ , splitOnParse , timeout ) where @@ -129,20 +131,38 @@ -- Value-less keys are not supported: -- -- >>> var keyValues "TAGS" mempty `parsePure` [("TAGS", "foo,baz:bat")]--- Left [("TAGS",UnreadError "Key foo has no value: \"foo,baz:bat\"")]+-- Left [("TAGS",UnreadError "Key foo has no value: \"foo\"")] -- -- Nor are key-less values: -- -- >>> var keyValues "TAGS" mempty `parsePure` [("TAGS", "foo:bar,:bat")]--- Left [("TAGS",UnreadError "Value bat has no key: \"foo:bar,:bat\"")]+-- Left [("TAGS",UnreadError "Value bat has no key: \":bat\"")] keyValues :: Reader Error [(Text, Text)]-keyValues = eitherReader $ traverse keyValue . T.splitOn "," . pack+keyValues = splitOnParse ',' $ keyValue ':'++keyValue :: Char -> Reader Error (Text, Text)+keyValue c =+ eitherReader $ go . second (T.drop 1) . T.breakOn (T.singleton c) . pack where- keyValue :: Text -> Either String (Text, Text)- keyValue t = case second (T.drop 1) $ T.breakOn ":" t of+ go = \case (k, v) | T.null v -> Left $ "Key " <> unpack k <> " has no value" (k, v) | T.null k -> Left $ "Value " <> unpack v <> " has no key" (k, v) -> Right (k, v)++-- | Use 'splitOn' then call the given 'Reader' on each element+--+-- @+-- 'splitOnParse' c pure == 'splitOn' c+-- @+--+-- >>> var (splitOnParse @Error ',' nonempty) "X" mempty `parsePure` [("X", "a,b")]+-- Right ["a","b"]+--+-- >>> var (splitOnParse @Error ',' nonempty) "X" mempty `parsePure` [("X", ",,")]+-- Left [("X",EmptyError)]+--+splitOnParse :: Char -> Reader e a -> Reader e [a]+splitOnParse c p = traverse p <=< splitOn c -- | Represents a timeout in seconds or milliseconds data Timeout
library/Freckle/App/Test.hs view
@@ -45,7 +45,12 @@ 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@@ -124,6 +129,12 @@ 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 --
package.yaml view
@@ -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