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