47 lines
1.8 KiB
Haskell
47 lines
1.8 KiB
Haskell
module Foundation.DB
|
|
( runDBRead
|
|
, runSqlPoolRetry
|
|
) where
|
|
|
|
import Import.NoFoundation hiding (runDB, getDBRunner)
|
|
|
|
import Foundation.Type
|
|
|
|
import qualified Control.Retry as Retry
|
|
import GHC.IO.Exception (IOErrorType(OtherError))
|
|
|
|
import Database.Persist.Sql (runSqlPool, SqlReadBackend(..))
|
|
|
|
|
|
runSqlPoolRetry :: forall m a backend.
|
|
( MonadUnliftIO m, BackendCompatible SqlBackend backend
|
|
, MonadLogger m, MonadMask m
|
|
)
|
|
=> ReaderT backend m a
|
|
-> Pool backend
|
|
-> m a
|
|
runSqlPoolRetry action pool = do
|
|
let policy = Retry.fullJitterBackoff 1e3 & Retry.limitRetriesByCumulativeDelay 10e6
|
|
handlers = Retry.skipAsyncExceptions `snoc` Retry.logRetries suggestRetry logRetry
|
|
where suggestRetry :: IOException -> m Bool
|
|
suggestRetry ioExc = return $
|
|
ioeGetErrorType ioExc == OtherError
|
|
&& ioeGetLocation ioExc == "libpq"
|
|
logRetry :: forall e.
|
|
Exception e
|
|
=> Bool -- ^ Will retry
|
|
-> e
|
|
-> Retry.RetryStatus
|
|
-> m ()
|
|
logRetry shouldRetry@False err status = $logErrorS "runSqlPoolRetry" . pack $ Retry.defaultLogMsg shouldRetry err status
|
|
logRetry shouldRetry@True err status = $logWarnS "runSqlPoolRetry" . pack $ Retry.defaultLogMsg shouldRetry err status
|
|
|
|
Retry.recovering policy handlers $ \Retry.RetryStatus{..} -> do
|
|
$logDebugS "runSqlPoolRetry" $ "rsIterNumber = " <> tshow rsIterNumber
|
|
runSqlPool action pool
|
|
|
|
runDBRead :: ReaderT SqlReadBackend (HandlerFor UniWorX) a -> (HandlerFor UniWorX) a
|
|
runDBRead action = do
|
|
$logDebugS "YesodPersist" "runDBRead"
|
|
runSqlPoolRetry (withReaderT SqlReadBackend action) . appConnPool =<< getYesod
|