fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(db): track source of database accesses

Browse Source
This commit is contained in:
Gregor Kleen 2021-02-26 11:00:44 +01:00
parent fd57bbce3d
commit 23ff9d9222
14 changed files with 217 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/Application.hs
View File

@ -207,7 +207,7 @@ makeFoundation appSettings''@AppSettings{..} = do
-- temporary foundation without a real connection pool, get a log function -- temporary foundation without a real connection pool, get a log function
-- from there, and then create the real foundation. -- from there, and then create the real foundation.
let let
mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool m SqlBackend) -> _ mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend) -> _
mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey = UniWorX {..} mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey = UniWorX {..}
-- The UniWorX {..} syntax is an example of record wild cards. For more -- The UniWorX {..} syntax is an example of record wild cards. For more
-- information, see: -- information, see:
@ -257,8 +257,8 @@ makeFoundation appSettings''@AppSettings{..} = do
liftIO $ connClose conn liftIO $ connClose conn
observeDatabaseConnectionClosed observeDatabaseConnectionClosed
$logDebugS "SqlPool" "Closed connection" $logDebugS "SqlPool" "Closed connection"
in Custom.createPool (liftIO . flip runLoggingT logFunc) create destroy (Just . fromIntegral $ pgPoolIdleTimeout appDatabaseConf) (Just $ pgPoolSize appDatabaseConf) in Custom.createPool' (liftIO . flip runLoggingT logFunc) create destroy ((flip runLoggingT logFunc .) . onUseDBConn) onReleaseDBConn (Just . fromIntegral $ pgPoolIdleTimeout appDatabaseConf) (Just $ pgPoolSize appDatabaseConf)
let sqlPool :: forall m. MonadIO m => Custom.Pool m SqlBackend let sqlPool :: forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend
sqlPool = Custom.hoistPool (liftIO . flip runLoggingT logFunc) sqlPool' sqlPool = Custom.hoistPool (liftIO . flip runLoggingT logFunc) sqlPool'
void . Prometheus.register . poolMetrics PoolDatabaseConnections $ sqlPool @IO void . Prometheus.register . poolMetrics PoolDatabaseConnections $ sqlPool @IO
@ -332,7 +332,7 @@ mkSessionStore :: forall m.
, MonadResource m , MonadResource m
) )
=> AppSettings => AppSettings
-> (forall m'. MonadIO m' => Custom.Pool m' SqlBackend) -> (forall m'. MonadIO m' => Custom.Pool' m' DBConnLabel DBConnUseState SqlBackend)
-> ReaderT SqlBackend m SomeSessionStorage -> ReaderT SqlBackend m SomeSessionStorage
mkSessionStore AppSettings{..} mcdSqlConnPool mkSessionStore AppSettings{..} mcdSqlConnPool
| Just mcdConf@MemcachedConf{..} <- appSessionMemcachedConf = do | Just mcdConf@MemcachedConf{..} <- appSessionMemcachedConf = do

50
src/Foundation/Authorization.hs
View File

@ -95,13 +95,13 @@ data AccessPredicate
| APDB (ByteString -> (forall m. MonadAP m => AuthTagsEval m) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult) | APDB (ByteString -> (forall m. MonadAP m => AuthTagsEval m) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult)
class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where
evalAccessPred :: AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult evalAccessPred :: HasCallStack => AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where
evalAccessPred aPred contCtx cont aid r w = liftHandler $ case aPred of evalAccessPred aPred contCtx cont aid r w = liftHandler $ case aPred of
(APPure p) -> runReader (p aid r w) <$> getMsgRenderer (APPure p) -> runReader (p aid r w) <$> getMsgRenderer
(APHandler p) -> p aid r w (APHandler p) -> p aid r w
(APDB p) -> runDBRead $ p contCtx cont aid r w (APDB p) -> runDBRead' callStack $ p contCtx cont aid r w
instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, BearerAuthSite UniWorX) => MonadAP (ReaderT backend m) where instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, BearerAuthSite UniWorX) => MonadAP (ReaderT backend m) where
evalAccessPred aPred contCtx cont aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of evalAccessPred aPred contCtx cont aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of
@ -180,7 +180,8 @@ getAuthContext = liftHandler $ do
return authCtx return authCtx
isDryRun :: forall m. isDryRun :: forall m.
( MonadHandler m, HandlerSite m ~ UniWorX ( HasCallStack
, MonadHandler m, HandlerSite m ~ UniWorX
, BearerAuthSite UniWorX , BearerAuthSite UniWorX
) )
=> m Bool => m Bool
@ -1533,7 +1534,7 @@ routeAuthTags = fmap predDNFEntail . ofoldM parse defaultAuthDNF . routeAttrs
Just t' -> Right . predDNFOr prev . PredDNF $ Set.singleton t' Just t' -> Right . predDNFOr prev . PredDNF $ Set.singleton t'
Nothing -> Left $ InvalidAuthTag t Nothing -> Left $ InvalidAuthTag t
evalAuthTags :: forall ctx m. (Binary ctx, MonadAP m) => ctx -> AuthTagActive -> (forall m'. MonadAP m' => AuthTagsEval m') -> AuthTagsEval m evalAuthTags :: forall ctx m. (HasCallStack, Binary ctx, MonadAP m) => ctx -> AuthTagActive -> (forall m'. MonadAP m' => AuthTagsEval m') -> AuthTagsEval m
-- ^ `tell`s disabled predicates, identified as pivots -- ^ `tell`s disabled predicates, identified as pivots
evalAuthTags ctx authActive@AuthTagActive{..} cont (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite evalAuthTags ctx authActive@AuthTagActive{..} cont (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite
= do = do
@ -1579,7 +1580,7 @@ evalAuthTags ctx authActive@AuthTagActive{..} cont (map (Set.toList . toNullable
return result return result
evalAccessWithFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => [(AuthTag, Bool)] -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult evalAccessWithFor :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => [(AuthTag, Bool)] -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
evalAccessWithFor assumptions mAuthId route isWrite = do evalAccessWithFor assumptions mAuthId route isWrite = do
isSelf <- (== mAuthId) <$> liftHandler defaultMaybeAuthId isSelf <- (== mAuthId) <$> liftHandler defaultMaybeAuthId
tagActive <- if tagActive <- if
@ -1597,42 +1598,42 @@ evalAccessWithFor assumptions mAuthId route isWrite = do
tellSessionJson SessionInactiveAuthTags deactivated tellSessionJson SessionInactiveAuthTags deactivated
return result return result
evalAccessFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult evalAccessFor :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
evalAccessFor = evalAccessWithFor [] evalAccessFor = evalAccessWithFor []
evalAccessForDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessForDB :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT backend m AuthResult
evalAccessForDB = evalAccessFor evalAccessForDB = evalAccessFor
evalAccessWith :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> m AuthResult evalAccessWith :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> m AuthResult
evalAccessWith assumptions route isWrite = do evalAccessWith assumptions route isWrite = do
mAuthId <- liftHandler maybeAuthId mAuthId <- liftHandler maybeAuthId
evalAccessWithFor assumptions mAuthId route isWrite evalAccessWithFor assumptions mAuthId route isWrite
evalAccessWithDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessWithDB :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult
evalAccessWithDB = evalAccessWith evalAccessWithDB = evalAccessWith
evalAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> Bool -> m AuthResult evalAccess :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> Bool -> m AuthResult
evalAccess = evalAccessWith [] evalAccess = evalAccessWith []
evalAccessDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessDB :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => Route UniWorX -> Bool -> ReaderT backend m AuthResult
evalAccessDB = evalAccess evalAccessDB = evalAccess
-- | Check whether the current user is authorized by `evalAccess` for the given route -- | Check whether the current user is authorized by `evalAccess` for the given route
-- Convenience function for a commonly used code fragment -- Convenience function for a commonly used code fragment
hasAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> Bool -> m Bool hasAccessTo :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> Bool -> m Bool
hasAccessTo route isWrite = (== Authorized) <$> evalAccess route isWrite hasAccessTo route isWrite = (== Authorized) <$> evalAccess route isWrite
-- | Check whether the current user is authorized by `evalAccess` to read from the given route -- | Check whether the current user is authorized by `evalAccess` to read from the given route
-- Convenience function for a commonly used code fragment -- Convenience function for a commonly used code fragment
hasReadAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> m Bool hasReadAccessTo :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> m Bool
hasReadAccessTo = flip hasAccessTo False hasReadAccessTo = flip hasAccessTo False
-- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route -- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route
-- Convenience function for a commonly used code fragment -- Convenience function for a commonly used code fragment
hasWriteAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> m Bool hasWriteAccessTo :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> m Bool
hasWriteAccessTo = flip hasAccessTo True hasWriteAccessTo = flip hasAccessTo True
wouldHaveAccessTo :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX ) wouldHaveAccessTo :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX)
=> [(AuthTag, Bool)] -- ^ Assumptions => [(AuthTag, Bool)] -- ^ Assumptions
-> Route UniWorX -> Route UniWorX
-> Bool -> Bool
@ -1640,7 +1641,7 @@ wouldHaveAccessTo :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, Be
wouldHaveAccessTo assumptions route isWrite = (== Authorized) <$> evalAccessWith assumptions route isWrite wouldHaveAccessTo assumptions route isWrite = (== Authorized) <$> evalAccessWith assumptions route isWrite
wouldHaveReadAccessTo, wouldHaveWriteAccessTo wouldHaveReadAccessTo, wouldHaveWriteAccessTo
:: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX ) :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX)
=> [(AuthTag, Bool)] -- ^ Assumptions => [(AuthTag, Bool)] -- ^ Assumptions
-> Route UniWorX -> Route UniWorX
-> m Bool -> m Bool
@ -1648,7 +1649,7 @@ wouldHaveReadAccessTo assumptions route = wouldHaveAccessTo assumptions route Fa
wouldHaveWriteAccessTo assumptions route = wouldHaveAccessTo assumptions route True wouldHaveWriteAccessTo assumptions route = wouldHaveAccessTo assumptions route True
wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff
:: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX ) :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX)
=> [(AuthTag, Bool)] -- ^ Assumptions => [(AuthTag, Bool)] -- ^ Assumptions
-> Route UniWorX -> Route UniWorX
-> m Bool -> m Bool
@ -1657,7 +1658,8 @@ wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo ro
evalWorkflowRoleFor' :: forall m backend. evalWorkflowRoleFor' :: forall m backend.
( MonadHandler m ( HasCallStack
, MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, BearerAuthSite UniWorX , BearerAuthSite UniWorX
, BackendCompatible SqlReadBackend backend , BackendCompatible SqlReadBackend backend
@ -1705,7 +1707,8 @@ evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = do
return Authorized return Authorized
WorkflowRoleAuthorized{..} -> eval (predDNFEntail $ workflowRoleAuthorized `predDNFOr` defaultAuthDNF) mAuthId route isWrite WorkflowRoleAuthorized{..} -> eval (predDNFEntail $ workflowRoleAuthorized `predDNFOr` defaultAuthDNF) mAuthId route isWrite
evalWorkflowRoleFor :: ( MonadHandler m evalWorkflowRoleFor :: ( HasCallStack
, MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, BearerAuthSite UniWorX , BearerAuthSite UniWorX
, BackendCompatible SqlReadBackend backend , BackendCompatible SqlReadBackend backend
@ -1729,7 +1732,8 @@ evalWorkflowRoleFor mAuthId mwwId wRole route isWrite = do
tellSessionJson SessionInactiveAuthTags deactivated tellSessionJson SessionInactiveAuthTags deactivated
return result return result
hasWorkflowRole :: ( MonadHandler m hasWorkflowRole :: ( HasCallStack
, MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, BearerAuthSite UniWorX , BearerAuthSite UniWorX
, BackendCompatible SqlReadBackend backend , BackendCompatible SqlReadBackend backend
@ -1744,7 +1748,8 @@ hasWorkflowRole mwwId wRole route isWrite = do
evalWorkflowRoleFor mAuthId mwwId wRole route isWrite evalWorkflowRoleFor mAuthId mwwId wRole route isWrite
mayViewWorkflowAction' :: forall backend m fileid. mayViewWorkflowAction' :: forall backend m fileid.
( MonadHandler m ( HasCallStack
, MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, BearerAuthSite UniWorX , BearerAuthSite UniWorX
, BackendCompatible SqlReadBackend backend , BackendCompatible SqlReadBackend backend
@ -1774,7 +1779,8 @@ mayViewWorkflowAction' eval mAuthId wwId WorkflowAction{..} = hoist (withReaderT
return True return True
mayViewWorkflowAction :: forall backend m fileid. mayViewWorkflowAction :: forall backend m fileid.
( MonadHandler m ( HasCallStack
, MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, BearerAuthSite UniWorX , BearerAuthSite UniWorX
, BackendCompatible SqlReadBackend backend , BackendCompatible SqlReadBackend backend

34
src/Foundation/DB.hs
View File

@ -1,6 +1,6 @@
module Foundation.DB module Foundation.DB
( runDBRead ( runDBRead, runDBRead'
, runSqlPoolRetry , runSqlPoolRetry, runSqlPoolRetry'
) where ) where
import Import.NoFoundation hiding (runDB, getDBRunner) import Import.NoFoundation hiding (runDB, getDBRunner)
@ -16,14 +16,25 @@ import Database.Persist.Sql.Raw.QQ (executeQQ)
import qualified Utils.Pool as Custom import qualified Utils.Pool as Custom
runSqlPoolRetry :: forall m a backend. runSqlPoolRetry :: forall m a backend c.
( MonadUnliftIO m, BackendCompatible SqlBackend backend ( HasCallStack
, MonadUnliftIO m, BackendCompatible SqlBackend backend
, MonadLogger m, MonadMask m , MonadLogger m, MonadMask m
) )
=> ReaderT backend m a => ReaderT backend m a
-> Custom.Pool m backend -> Custom.Pool' m DBConnLabel c backend
-> m a -> m a
runSqlPoolRetry action pool = do runSqlPoolRetry action pool = runSqlPoolRetry' action pool callStack
runSqlPoolRetry' :: forall m a backend c.
( MonadUnliftIO m, BackendCompatible SqlBackend backend
, MonadLogger m, MonadMask m
)
=> ReaderT backend m a
-> Custom.Pool' m DBConnLabel c backend
-> CallStack
-> m a
runSqlPoolRetry' action pool lbl = do
let policy = Retry.fullJitterBackoff 1e3 & Retry.limitRetriesByCumulativeDelay 10e6 let policy = Retry.fullJitterBackoff 1e3 & Retry.limitRetriesByCumulativeDelay 10e6
handlers = Retry.skipAsyncExceptions `snoc` Retry.logRetries suggestRetry logRetry handlers = Retry.skipAsyncExceptions `snoc` Retry.logRetries suggestRetry logRetry
where suggestRetry :: IOException -> m Bool where suggestRetry :: IOException -> m Bool
@ -41,9 +52,12 @@ runSqlPoolRetry action pool = do
Retry.recovering policy handlers $ \Retry.RetryStatus{..} -> do Retry.recovering policy handlers $ \Retry.RetryStatus{..} -> do
$logDebugS "runSqlPoolRetry" $ "rsIterNumber = " <> tshow rsIterNumber $logDebugS "runSqlPoolRetry" $ "rsIterNumber = " <> tshow rsIterNumber
customRunSqlPool action pool customRunSqlPool' action pool lbl
runDBRead :: ReaderT SqlReadBackend (HandlerFor UniWorX) a -> (HandlerFor UniWorX) a runDBRead :: HasCallStack => ReaderT SqlReadBackend (HandlerFor UniWorX) a -> (HandlerFor UniWorX) a
runDBRead action = do runDBRead = runDBRead' callStack
runDBRead' :: CallStack -> ReaderT SqlReadBackend (HandlerFor UniWorX) a -> (HandlerFor UniWorX) a
runDBRead' lbl action = do
$logDebugS "YesodPersist" "runDBRead" $logDebugS "YesodPersist" "runDBRead"
runSqlPoolRetry (withReaderT SqlReadBackend $ [executeQQ|SET TRANSACTION READ ONLY|] *> action) . appConnPool =<< getYesod flip (runSqlPoolRetry' . withReaderT SqlReadBackend $ [executeQQ|SET TRANSACTION READ ONLY|] *> action) lbl . appConnPool =<< getYesod

12
src/Foundation/Instances.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE UndecidableInstances #-} -- for `MonadCrypto` and `MonadSecretBox` {-# LANGUAGE UndecidableInstances #-} -- for `MonadCrypto` and `MonadSecretBox`
{-# LANGUAGE InstanceSigs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Foundation.Instances module Foundation.Instances
@ -128,11 +129,13 @@ unsafeHandler f h = do
-- How to run database actions. -- How to run database actions.
instance YesodPersist UniWorX where instance YesodPersist UniWorX where
type YesodPersistBackend UniWorX = SqlBackend type YesodPersistBackend UniWorX = SqlBackend
runDB = UniWorX.runDB runDB :: HasCallStack => YesodDB UniWorX a -> HandlerFor UniWorX a
runDB = UniWorX.runDB' callStack
instance YesodPersistRunner UniWorX where instance YesodPersistRunner UniWorX where
getDBRunner = UniWorX.getDBRunner getDBRunner :: HasCallStack => HandlerFor UniWorX (DBRunner UniWorX, HandlerFor UniWorX ())
getDBRunner = UniWorX.getDBRunner' callStack
instance YesodAuth UniWorX where instance YesodAuth UniWorX where
@ -187,7 +190,8 @@ instance YesodAuth UniWorX where
hoistMaybe bearerImpersonate hoistMaybe bearerImpersonate
instance YesodAuthPersist UniWorX where instance YesodAuthPersist UniWorX where
getAuthEntity = liftHandler . runDBRead . get getAuthEntity :: (HasCallStack, MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (Maybe User)
getAuthEntity = liftHandler . runDBRead' callStack . get
instance YesodMail UniWorX where instance YesodMail UniWorX where

9
src/Foundation/Navigation.hs
View File

@ -16,7 +16,7 @@ module Foundation.Navigation
, evalAccessCorrector , evalAccessCorrector
) where ) where
import Import.NoFoundation import Import.NoFoundation hiding (runDB)
import Foundation.Type import Foundation.Type
import Foundation.Routes import Foundation.Routes
@ -525,7 +525,6 @@ defaultLinks :: ( MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
, BearerAuthSite UniWorX , BearerAuthSite UniWorX
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
) => m [Nav] ) => m [Nav]
defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header. defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header.
[ return NavHeader [ return NavHeader
@ -710,7 +709,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
} }
, do , do
authCtx <- getAuthContext authCtx <- getAuthContext
(haveInstances, haveWorkflows) <- $memcachedByHere (Just $ Right diffDay) authCtx . liftHandler . runDB $ (,) -- We don't expect haveTopWorkflowWorkflows to be relevant and haveTopWorkflowInstances shouldn't change often (haveInstances, haveWorkflows) <- $memcachedByHere (Just $ Right diffDay) authCtx . liftHandler . runDBRead $ (,) -- We don't expect haveTopWorkflowWorkflows to be relevant and haveTopWorkflowInstances shouldn't change often
<$> haveTopWorkflowInstances <$> haveTopWorkflowInstances
<*> haveTopWorkflowWorkflows <*> haveTopWorkflowWorkflows
@ -2481,7 +2480,7 @@ pageActions route | Just (rScope, WorkflowInstanceListR) <- route ^? _WorkflowSc
{ navLink = NavLink { navLink = NavLink
{ navLabel = MsgMenuWorkflowWorkflowList { navLabel = MsgMenuWorkflowWorkflowList
, navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR) , navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR)
, navAccess' = runDB $ haveWorkflowWorkflows rScope , navAccess' = runDBRead $ haveWorkflowWorkflows rScope
, navType = NavTypeLink { navModal = False } , navType = NavTypeLink { navModal = False }
, navQuick' = mempty , navQuick' = mempty
, navForceActive = False , navForceActive = False
@ -2550,7 +2549,7 @@ pageActions TopWorkflowInstanceListR = return
{ navLink = NavLink { navLink = NavLink
{ navLabel = MsgMenuTopWorkflowWorkflowList { navLabel = MsgMenuTopWorkflowWorkflowList
, navRoute = TopWorkflowWorkflowListR , navRoute = TopWorkflowWorkflowListR
, navAccess' = runDB haveTopWorkflowWorkflows , navAccess' = runDBRead haveTopWorkflowWorkflows
, navType = NavTypeLink { navModal = False } , navType = NavTypeLink { navModal = False }
, navQuick' = mempty , navQuick' = mempty
, navForceActive = False , navForceActive = False

4
src/Foundation/Type.hs
View File

@ -28,6 +28,8 @@ import Data.IntervalMap.Strict (IntervalMap)
import qualified Utils.Pool as Custom import qualified Utils.Pool as Custom
import Utils.Metrics (DBConnUseState)
type SMTPPool = Pool SMTPConnection type SMTPPool = Pool SMTPConnection
@ -44,7 +46,7 @@ makePrisms ''SomeSessionStorage
data UniWorX = UniWorX data UniWorX = UniWorX
{ appSettings' :: AppSettings { appSettings' :: AppSettings
, appStatic :: EmbeddedStatic -- ^ Settings for static file serving. , appStatic :: EmbeddedStatic -- ^ Settings for static file serving.
, appConnPool :: forall m. MonadIO m => Custom.Pool m SqlBackend -- ^ Database connection pool. , appConnPool :: forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend -- ^ Database connection pool.
, appSmtpPool :: Maybe SMTPPool , appSmtpPool :: Maybe SMTPPool
, appLdapPool :: Maybe (Failover (LdapConf, LdapPool)) , appLdapPool :: Maybe (Failover (LdapConf, LdapPool))
, appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool , appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool

25
src/Foundation/Yesod/Persist.hs
View File

@ -1,5 +1,6 @@
module Foundation.Yesod.Persist module Foundation.Yesod.Persist
( runDB, getDBRunner ( runDB, getDBRunner
, runDB', getDBRunner'
, module Foundation.DB , module Foundation.DB
) where ) where
@ -19,30 +20,42 @@ import UnliftIO.Resource (allocate, unprotect)
runDB :: ( YesodPersistBackend UniWorX ~ SqlBackend runDB :: ( YesodPersistBackend UniWorX ~ SqlBackend
, BearerAuthSite UniWorX , BearerAuthSite UniWorX
, HasCallStack
) )
=> YesodDB UniWorX a -> HandlerFor UniWorX a => YesodDB UniWorX a -> HandlerFor UniWorX a
runDB action = do runDB = runDB' callStack
-- stack <- liftIO currentCallStack
-- $logDebugS "YesodPersist" . unlines $ "runDB" : map pack stack runDB' :: ( YesodPersistBackend UniWorX ~ SqlBackend
, BearerAuthSite UniWorX
)
=> CallStack -> YesodDB UniWorX a -> HandlerFor UniWorX a
runDB' lbl action = do
$logDebugS "YesodPersist" "runDB" $logDebugS "YesodPersist" "runDB"
dryRun <- isDryRun dryRun <- isDryRun
let action' let action'
| dryRun = action <* transactionUndo | dryRun = action <* transactionUndo
| otherwise = action | otherwise = action
runSqlPoolRetry action' . appConnPool =<< getYesod flip (runSqlPoolRetry' action') lbl . appConnPool =<< getYesod
getDBRunner :: ( YesodPersistBackend UniWorX ~ SqlBackend getDBRunner :: ( YesodPersistBackend UniWorX ~ SqlBackend
, BearerAuthSite UniWorX , BearerAuthSite UniWorX
, HasCallStack
) )
=> HandlerFor UniWorX (DBRunner UniWorX, HandlerFor UniWorX ()) => HandlerFor UniWorX (DBRunner UniWorX, HandlerFor UniWorX ())
getDBRunner = do getDBRunner = getDBRunner' callStack
getDBRunner' :: ( YesodPersistBackend UniWorX ~ SqlBackend
, BearerAuthSite UniWorX
)
=> CallStack -> HandlerFor UniWorX (DBRunner UniWorX, HandlerFor UniWorX ())
getDBRunner' lbl = do
pool <- getsYesod appConnPool pool <- getsYesod appConnPool
UnliftIO{..} <- askUnliftIO UnliftIO{..} <- askUnliftIO
let withPrep conn f = f (persistBackend conn) (SQL.getStmtConn $ persistBackend conn) let withPrep conn f = f (persistBackend conn) (SQL.getStmtConn $ persistBackend conn)
(relKey, (conn, ident)) <- allocate (relKey, (conn, ident)) <- allocate
(do (do
(conn, ident) <- unliftIO $ Custom.takeResource pool (conn, ident) <- unliftIO $ Custom.takeResource' pool lbl
withPrep conn (\c f -> SQL.connBegin c f Nothing) withPrep conn (\c f -> SQL.connBegin c f Nothing)
return (conn, ident) return (conn, ident)
) )

26
src/Handler/Utils/Form.hs
View File

@ -1452,38 +1452,34 @@ fsUniq :: (Text -> Text) -> Text -> FieldSettings site
fsUniq mkUnique seed = "" { fsName = Just $ mkUnique seed } fsUniq mkUnique seed = "" { fsName = Just $ mkUnique seed }
optionsPersistCryptoId :: forall site backend a msg. optionsPersistCryptoId :: forall backend a msg.
( YesodPersist site ( PersistQueryRead backend
, PersistQueryRead backend , HasCryptoUUID (Key a) (HandlerFor UniWorX)
, HasCryptoUUID (Key a) (HandlerFor site)
, KnownSymbol (CryptoIDNamespace UUID (Key a)) , KnownSymbol (CryptoIDNamespace UUID (Key a))
, RenderMessage site msg , RenderMessage UniWorX msg
, YesodPersistBackend site ~ backend , YesodPersistBackend UniWorX ~ backend
, PersistRecordBackend a backend , PersistRecordBackend a backend
, PathPiece (Key a) , PathPiece (Key a)
) )
=> [Filter a] => [Filter a]
-> [SelectOpt a] -> [SelectOpt a]
-> (a -> msg) -> (a -> msg)
-> HandlerFor site (OptionList (Entity a)) -> HandlerFor UniWorX (OptionList (Entity a))
optionsPersistCryptoId filts ords toDisplay = do optionsPersistCryptoId filts ords toDisplay = do
ents <- runDB $ selectList filts ords ents <- runDB $ selectList filts ords
optionsCryptoIdF ents (return . entityKey) (return . toDisplay . entityVal) optionsCryptoIdF ents (return . entityKey) (return . toDisplay . entityVal)
optionsCryptoIdE :: forall site backend a msg. optionsCryptoIdE :: forall backend a msg.
( YesodPersist site ( HasCryptoUUID (Key a) (HandlerFor UniWorX)
, PersistQueryRead backend, PersistUniqueRead backend
, HasCryptoUUID (Key a) (HandlerFor site)
, KnownSymbol (CryptoIDNamespace UUID (Key a)) , KnownSymbol (CryptoIDNamespace UUID (Key a))
, RenderMessage site msg , RenderMessage UniWorX msg
, YesodPersistBackend site ~ backend , YesodPersistBackend UniWorX ~ backend
, PersistRecordBackend a backend , PersistRecordBackend a backend
, BackendCompatible SqlBackend backend
, PathPiece (Key a) , PathPiece (Key a)
) )
=> E.SqlQuery (E.SqlExpr (Entity a)) => E.SqlQuery (E.SqlExpr (Entity a))
-> (a -> msg) -> (a -> msg)
-> HandlerFor site (OptionList (Entity a)) -> HandlerFor UniWorX (OptionList (Entity a))
optionsCryptoIdE query toDisplay = do optionsCryptoIdE query toDisplay = do
ents <- runDB $ E.select query ents <- runDB $ E.select query
optionsCryptoIdF ents (return . entityKey) (return . toDisplay . entityVal) optionsCryptoIdF ents (return . entityKey) (return . toDisplay . entityVal)

3
src/Import.hs
View File

@ -3,7 +3,8 @@ module Import
) where ) where
import Foundation as Import import Foundation as Import
import Import.NoFoundation as Import import Foundation.Yesod.Persist as Import (runDB, getDBRunner)
import Import.NoFoundation as Import hiding (runDB, getDBRunner)
import Model.Migration as Import import Model.Migration as Import
import Utils.SystemMessage as Import import Utils.SystemMessage as Import

1
src/Import/NoModel.hs
View File

@ -62,6 +62,7 @@ import Network.HaskellNet.SMTP as Import (SMTPConnection)
import Data.Data as Import (Data) import Data.Data as Import (Data)
import GHC.Exts as Import (IsList) import GHC.Exts as Import (IsList)
import Data.Ix as Import (Ix) import Data.Ix as Import (Ix)
import GHC.Stack as Import (CallStack, HasCallStack, callStack)
import Data.Hashable as Import import Data.Hashable as Import
import Data.List as Import (elemIndex) import Data.List as Import (elemIndex)

18
src/Utils/DB.hs
View File

@ -18,6 +18,8 @@ import qualified Utils.Pool as Custom
import Database.Persist.Sql (runSqlConn) import Database.Persist.Sql (runSqlConn)
import GHC.Stack (HasCallStack, CallStack, callStack)
emptyOrIn :: PersistField typ emptyOrIn :: PersistField typ
=> E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool) => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)
@ -159,5 +161,17 @@ selectMaybe fltrs opts = listToMaybe <$> selectList fltrs (LimitTo 1 : opts')
_other -> False _other -> False
customRunSqlPool :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Custom.Pool m backend -> m a type DBConnLabel = CallStack
customRunSqlPool act p = Custom.withResource p $ runSqlConn act
customRunSqlPool :: (HasCallStack, MonadUnliftIO m, BackendCompatible SqlBackend backend)
=> ReaderT backend m a
-> Custom.Pool' m DBConnLabel c backend
-> m a
customRunSqlPool act p = customRunSqlPool' act p callStack
customRunSqlPool' :: (MonadUnliftIO m, BackendCompatible SqlBackend backend)
=> ReaderT backend m a
-> Custom.Pool' m DBConnLabel c backend
-> CallStack
-> m a
customRunSqlPool' act p label = Custom.withResource' p label $ runSqlConn act

34
src/Utils/Metrics.hs
View File

@ -23,6 +23,7 @@ module Utils.Metrics
, PoolMetrics, PoolLabel(..) , PoolMetrics, PoolLabel(..)
, poolMetrics , poolMetrics
, observeDatabaseConnectionOpened, observeDatabaseConnectionClosed , observeDatabaseConnectionOpened, observeDatabaseConnectionClosed
, onUseDBConn, onReleaseDBConn, DBConnUseState, DBConnLabel
) where ) where
import Import.NoModel hiding (Vector, Info) import Import.NoModel hiding (Vector, Info)
@ -55,6 +56,8 @@ import qualified Data.Foldable as F
import qualified Utils.Pool as Custom import qualified Utils.Pool as Custom
import GHC.Stack
{-# ANN module ("HLint: ignore Use even" :: String) #-} {-# ANN module ("HLint: ignore Use even" :: String) #-}
@ -355,7 +358,7 @@ data PoolLabel = PoolDatabaseConnections
nullaryPathPiece ''PoolLabel $ camelToPathPiece' 1 nullaryPathPiece ''PoolLabel $ camelToPathPiece' 1
poolMetrics :: PoolLabel poolMetrics :: PoolLabel
-> Custom.Pool m a -> Custom.Pool' m c' c a
-> Metric PoolMetrics -> Metric PoolMetrics
poolMetrics lbl pool = Metric $ return (PoolMetrics, collectPoolMetrics) poolMetrics lbl pool = Metric $ return (PoolMetrics, collectPoolMetrics)
where where
@ -385,6 +388,35 @@ poolMetrics lbl pool = Metric $ return (PoolMetrics, collectPoolMetrics)
usesInfo = Info "uni2work_pool_uses_count" usesInfo = Info "uni2work_pool_uses_count"
"Number of takes executed against the pool" "Number of takes executed against the pool"
{-# NOINLINE databaseConnDuration #-}
databaseConnDuration :: Vector Label1 Histogram
databaseConnDuration = unsafeRegister . vector ("label") $ histogram info buckets
where
info = Info "uni2work_database_conn_duration_seconds"
"Duration of use of a database connection from the pool"
buckets = histogramBuckets 50e-6 5000
data DBConnUseState = DBConnUseState
{ dbConnUseStart :: !TimeSpec
, dbConnUseLabel :: !CallStack
} deriving (Show, Typeable)
onUseDBConn :: (MonadIO m, MonadLogger m) => CallStack -> a -> m DBConnUseState
onUseDBConn dbConnUseLabel _ = do
$logDebugS "DB" $ case getCallStack dbConnUseLabel of
[] -> "no stack"
xs -> intercalate "; " $ map (\(f, loc) -> pack f <> " @(" <> pack (prettySrcLoc loc) <> ")") xs
dbConnUseStart <- liftIO $ getTime Monotonic
return DBConnUseState{..}
onReleaseDBConn :: MonadIO m => DBConnUseState -> a -> m ()
onReleaseDBConn DBConnUseState{..} _ = liftIO $ do
diff <- realToFrac . subtract dbConnUseStart <$> getTime Monotonic
let lbl = case reverse $ getCallStack dbConnUseLabel of
[] -> "unlabeled"
(_, SrcLoc{..}) : _ -> pack srcLocModule
withLabel databaseConnDuration lbl $ flip observe diff
withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport
withHealthReportMetrics act = do withHealthReportMetrics act = do

87
src/Utils/Pool.hs
View File

@ -1,13 +1,16 @@
{-# OPTIONS_GHC -Wno-error=unused-top-binds #-} {-# OPTIONS_GHC -Wno-error=unused-top-binds #-}
module Utils.Pool module Utils.Pool
( Pool, hoistPool ( Pool', hoistPool
, PoolResourceIdent'
, Pool, PoolResourceIdent
, getPoolAvailableCount, getPoolInUseCount, getPoolUsesCount , getPoolAvailableCount, getPoolInUseCount, getPoolUsesCount
, createPool , createPool, createPool'
, purgePool , purgePool
, withResource , withResource, withResource'
, destroyResources , destroyResources
, takeResource, releaseResource , takeResource, releaseResource
, takeResource'
) where ) where
import ClassyPrelude import ClassyPrelude
@ -35,35 +38,42 @@ import Utils.NTop
-- <https://hackage.haskell.org/package/ex-pool-0.2.1/docs/src/Data-Pool.html> -- <https://hackage.haskell.org/package/ex-pool-0.2.1/docs/src/Data-Pool.html>
newtype PoolResourceIdent = PoolResourceIdent Int data PoolResourceIdent' c = PoolResourceIdent Int c
deriving (Eq, Ord, Show, Typeable) deriving (Eq, Ord, Show, Typeable)
data Pool m a = Pool data Pool' m c' c a = Pool
{ create :: m a { create :: m a
, destroy :: a -> m () , destroy :: a -> m ()
, onUse :: c' -> a -> m c
, onRelease :: c -> a -> m ()
, idleTime :: !(Maybe Int) , idleTime :: !(Maybe Int)
, maxAvailable :: !(Maybe Int) , maxAvailable :: !(Maybe Int)
, resources :: !(TVar (PoolResources a)) , resources :: !(TVar (PoolResources c a))
, aliveRef :: !(IORef ()) , aliveRef :: !(IORef ())
} }
data PoolResources a = PoolResources data PoolResources c a = PoolResources
{ inUseCount, availableCount :: !Int { inUseCount, availableCount :: !Int
, inUse :: !(IntMap a) , inUse :: !(IntMap a)
, available :: !(IntMap [a]) , available :: !(IntMap [a])
, inUseTick :: !Int , inUseTick :: !Int
} deriving (Functor) } deriving (Functor)
type Pool m a = Pool' m () () a
type PoolResourceIdent = PoolResourceIdent' ()
hoistPool :: (forall b. m b -> n b) -> Pool m a -> Pool n a
hoistPool :: (forall b. m b -> n b) -> Pool' m c' c a -> Pool' n c' c a
hoistPool nat Pool{..} = Pool hoistPool nat Pool{..} = Pool
{ create = nat create { create = nat create
, destroy = nat . destroy , destroy = nat . destroy
, onUse = (nat .) . onUse
, onRelease = (nat .) . onRelease
, .. , ..
} }
getPoolAvailableCount, getPoolInUseCount, getPoolUsesCount :: Pool m a -> STM Int getPoolAvailableCount, getPoolInUseCount, getPoolUsesCount :: Pool' m c' c a -> STM Int
getPoolAvailableCount Pool{..} = availableCount <$> readTVar resources getPoolAvailableCount Pool{..} = availableCount <$> readTVar resources
getPoolInUseCount Pool{..} = inUseCount <$> readTVar resources getPoolInUseCount Pool{..} = inUseCount <$> readTVar resources
getPoolUsesCount Pool{..} = inUseTick <$> readTVar resources getPoolUsesCount Pool{..} = inUseTick <$> readTVar resources
@ -83,7 +93,18 @@ createPool :: (MonadResource m, MonadUnliftIO m, MonadUnliftIO m')
-> Maybe Int -- ^ Timeout in seconds -> Maybe Int -- ^ Timeout in seconds
-> Maybe Int -- ^ Max available -> Maybe Int -- ^ Max available
-> m (Pool m' a) -> m (Pool m' a)
createPool nat create destroy (fmap $ max 0 -> idleTime) (fmap $ max 0 -> maxAvailable) = do createPool nat create destroy = createPool' nat create destroy (\() _ -> return ()) (\() _ -> return ())
createPool' :: (MonadResource m, MonadUnliftIO m, MonadUnliftIO m')
=> (forall b. m' b -> m b)
-> m' a -- ^ Create
-> (a -> m' ()) -- ^ Destroy
-> (c' -> a -> m' c) -- ^ onUse
-> (c -> a -> m' ()) -- ^ onRelease
-> Maybe Int -- ^ Timeout in seconds
-> Maybe Int -- ^ Max available
-> m (Pool' m' c' c a)
createPool' nat create destroy onUse onRelease (fmap $ max 0 -> idleTime) (fmap $ max 0 -> maxAvailable) = do
let let
inUseCount = 0 inUseCount = 0
availableCount = 0 availableCount = 0
@ -102,10 +123,10 @@ createPool nat create destroy (fmap $ max 0 -> idleTime) (fmap $ max 0 -> maxAva
return pool return pool
purgePool :: MonadUnliftIO m => Pool m a -> m () purgePool :: MonadUnliftIO m => Pool' m c' c a -> m ()
purgePool = destroyResources $ const True purgePool = destroyResources $ const True
reaper :: MonadUnliftIO m => (a -> m ()) -> TVar (PoolResources a) -> Int -> m () reaper :: MonadUnliftIO m => (a -> m ()) -> TVar (PoolResources c a) -> Int -> m ()
reaper destroy' resources' t = forever $ do reaper destroy' resources' t = forever $ do
atomically . waitDelay =<< liftIO (newDelay i) atomically . waitDelay =<< liftIO (newDelay i)
@ -124,8 +145,11 @@ reaper destroy' resources' t = forever $ do
where where
MkFixed (fromIntegral -> i) = 1 :: Micro MkFixed (fromIntegral -> i) = 1 :: Micro
takeResource :: MonadIO m => Pool m a -> m (a, PoolResourceIdent) takeResource :: MonadIO m => Pool m a -> m (a, PoolResourceIdent' ())
takeResource Pool{..} = do takeResource p = takeResource' p ()
takeResource' :: MonadIO m => Pool' m c' c a -> c' -> m (a, PoolResourceIdent' c)
takeResource' Pool{..} stateInit = do
takenAvailable <- atomically $ do takenAvailable <- atomically $ do
PoolResources{..} <- readTVar resources PoolResources{..} <- readTVar resources
case IntMap.maxViewWithKey available of case IntMap.maxViewWithKey available of
@ -147,7 +171,9 @@ takeResource Pool{..} = do
return $ Just (av, inUseTick) return $ Just (av, inUseTick)
_other -> return Nothing _other -> return Nothing
case takenAvailable of case takenAvailable of
Just (av, resTick) -> return (av, PoolResourceIdent resTick) Just (av, resTick) -> do
hookData <- onUse stateInit av
return (av, PoolResourceIdent resTick hookData)
Nothing -> do Nothing -> do
newResource <- create newResource <- create
resTick <- atomically . stateTVar resources $ \res@PoolResources{..} -> resTick <- atomically . stateTVar resources $ \res@PoolResources{..} ->
@ -157,12 +183,13 @@ takeResource Pool{..} = do
in ( inUseTick in ( inUseTick
, res{ inUseCount = inUseCount', inUse = inUse', inUseTick = inUseTick' } , res{ inUseCount = inUseCount', inUse = inUse', inUseTick = inUseTick' }
) )
return (newResource, PoolResourceIdent resTick) hookData <- onUse stateInit newResource
return (newResource, PoolResourceIdent resTick hookData)
releaseResource :: MonadUnliftIO m releaseResource :: MonadUnliftIO m
=> Bool -- ^ Destroy resource and don't return to pool? => Bool -- ^ Destroy resource and don't return to pool?
-> Pool m a -> Pool' m c' c a
-> (a, PoolResourceIdent) -> (a, PoolResourceIdent' c)
-> m () -> m ()
releaseResource isLost p@Pool{..} (x, ident) releaseResource isLost p@Pool{..} (x, ident)
| isLost = do | isLost = do
@ -171,27 +198,27 @@ releaseResource isLost p@Pool{..} (x, ident)
| otherwise | otherwise
= markResourceAvailable p ident = markResourceAvailable p ident
markResourceAvailable, markResourceLost :: MonadUnliftIO m => Pool m a -> PoolResourceIdent -> m () markResourceAvailable, markResourceLost :: MonadUnliftIO m => Pool' m c' c a -> PoolResourceIdent' c -> m ()
markResourceAvailable = returnResource True markResourceAvailable = returnResource True
markResourceLost = returnResource False markResourceLost = returnResource False
returnResource :: MonadUnliftIO m returnResource :: MonadUnliftIO m
=> Bool -- ^ return to available => Bool -- ^ return to available
-> Pool m a -> Pool' m c' c a
-> PoolResourceIdent -> PoolResourceIdent' c
-> m () -> m ()
returnResource toAvailable Pool{..} (PoolResourceIdent inUseKey) = do returnResource toAvailable Pool{..} (PoolResourceIdent inUseKey hookData) = do
now <- if | toAvailable -> Just <$> currentSecond now <- if | toAvailable -> Just <$> currentSecond
| otherwise -> return Nothing | otherwise -> return Nothing
toDestroy <- atomically . stateTVar resources $ \res@PoolResources{..} -> case deleteView inUseKey inUse of (toDestroy, released) <- atomically . stateTVar resources $ \res@PoolResources{..} -> case deleteView inUseKey inUse of
Nothing -> (Nothing, res) Nothing -> ((Nothing, Nothing), res)
Just (u, us) | NTop (Just availableCount) >= NTop maxAvailable Just (u, us) | NTop (Just availableCount) >= NTop maxAvailable
-> (Just u,) res -> ((Just u, Just u),) res
{ inUse = us { inUse = us
, inUseCount = pred inUseCount , inUseCount = pred inUseCount
} }
Just (u, us) Just (u, us)
-> (Nothing, ) PoolResources -> ((Nothing, Just u), ) PoolResources
{ inUse = us { inUse = us
, inUseCount = pred inUseCount , inUseCount = pred inUseCount
, availableCount = bool id succ toAvailable availableCount , availableCount = bool id succ toAvailable availableCount
@ -199,6 +226,7 @@ returnResource toAvailable Pool{..} (PoolResourceIdent inUseKey) = do
, inUseTick , inUseTick
} }
forM_ released $ \u -> onRelease hookData u
forM_ toDestroy $ void . forkIO . destroy forM_ toDestroy $ void . forkIO . destroy
where where
deleteView :: Int -> IntMap a -> Maybe (a, IntMap a) deleteView :: Int -> IntMap a -> Maybe (a, IntMap a)
@ -207,9 +235,12 @@ returnResource toAvailable Pool{..} (PoolResourceIdent inUseKey) = do
withResource :: forall b m a. MonadUnliftIO m => Pool m a -> (a -> m b) -> m b withResource :: forall b m a. MonadUnliftIO m => Pool m a -> (a -> m b) -> m b
withResource p act = bracketOnError (takeResource p) (releaseResource True p) (\x'@(x, _) -> act x <* releaseResource False p x') withResource p = withResource' p ()
destroyResources :: MonadUnliftIO m => (a -> Bool) -> Pool m a -> m () withResource' :: forall b m c' c a. MonadUnliftIO m => Pool' m c' c a -> c' -> (a -> m b) -> m b
withResource' p stateInit act = bracketOnError (takeResource' p stateInit) (releaseResource True p) (\x'@(x, _) -> act x <* releaseResource False p x')
destroyResources :: MonadUnliftIO m => (a -> Bool) -> Pool' m c' c a -> m ()
destroyResources p Pool{..} = do destroyResources p Pool{..} = do
toDestroy <- atomically . stateTVar resources $ \res@PoolResources{..} toDestroy <- atomically . stateTVar resources $ \res@PoolResources{..}
-> let partitioned = partition p <$> available -> let partitioned = partition p <$> available

6
src/Web/ServerSession/Backend/Persistent/Memcached.hs
View File

@ -29,6 +29,8 @@ import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Base64.URL as Base64 import qualified Data.ByteString.Base64.URL as Base64
import Utils.Metrics (DBConnUseState)
import Data.Text.Encoding (decodeUtf8') import Data.Text.Encoding (decodeUtf8')
@ -46,7 +48,7 @@ share [mkPersist sqlSettings, mkMigrate "migrateMemcachedSqlStorage"]
data MemcachedSqlStorage sess = MemcachedSqlStorage data MemcachedSqlStorage sess = MemcachedSqlStorage
{ mcdSqlConnPool :: forall m. MonadIO m => Custom.Pool m SqlBackend { mcdSqlConnPool :: forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend
, mcdSqlMemcached :: Memcached.Connection , mcdSqlMemcached :: Memcached.Connection
, mcdSqlMemcachedKey :: AEAD.Key , mcdSqlMemcachedKey :: AEAD.Key
, mcdSqlMemcachedExpiration :: Maybe NominalDiffTime , mcdSqlMemcachedExpiration :: Maybe NominalDiffTime
@ -108,7 +110,7 @@ instance (IsSessionData sess, Binary (Decomposed sess)) => Storage (MemcachedSql
type SessionData (MemcachedSqlStorage sess) = sess type SessionData (MemcachedSqlStorage sess) = sess
type TransactionM (MemcachedSqlStorage sess) = SqlPersistT IO type TransactionM (MemcachedSqlStorage sess) = SqlPersistT IO
runTransactionM MemcachedSqlStorage{..} = flip customRunSqlPool mcdSqlConnPool runTransactionM MemcachedSqlStorage{..} act = customRunSqlPool act mcdSqlConnPool
getSession MemcachedSqlStorage{..} sessId = exceptT (maybe (return Nothing) throwM) (return . Just) $ do getSession MemcachedSqlStorage{..} sessId = exceptT (maybe (return Nothing) throwM) (return . Just) $ do
encSession <- catchIfExceptT (const Nothing) Memcached.isKeyNotFound . liftIO . fmap LBS.toStrict $ Memcached.getAndTouch_ expiry (memcachedSqlSessionId # sessId) mcdSqlMemcached encSession <- catchIfExceptT (const Nothing) Memcached.isKeyNotFound . liftIO . fmap LBS.toStrict $ Memcached.getAndTouch_ expiry (memcachedSqlSessionId # sessId) mcdSqlMemcached