{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE TypeOperators #-}
module Freckle.App.Database.XRay
( MonadTracer (..)
, HasStatsClient
, HasSqlPool (..)
, SqlPool
, makePostgresPool
, makePostgresPoolWith
, runDB
, runDBSimple
, PostgresConnectionConf (..)
, PostgresPasswordSource (..)
, PostgresPassword (..)
, PostgresStatementTimeout
, postgresStatementTimeoutMilliseconds
, envParseDatabaseConf
, envPostgresPasswordSource
) where
import Freckle.App.Prelude
import Control.Monad.IO.Unlift (MonadUnliftIO (..))
import Control.Monad.Reader
import Data.Pool
import Database.Persist.Postgresql
( SqlBackend
, SqlPersistT
, runSqlConn
, runSqlPool
)
import Freckle.App.Database hiding (MonadTracer, runDB)
import qualified Freckle.App.Stats as Stats
import Network.AWS.XRayClient.Persistent
import Network.AWS.XRayClient.WAI
( XRayVaultData
, atomicallyAddVaultDataSubsegment
, traceXRaySubsegment'
, vaultDataFromRequest
, xrayVaultDataStdGen
)
import Yesod.Core (HandlerFor, waiRequest)
class MonadTracer m where
getVaultData :: m (Maybe XRayVaultData)
instance MonadTracer (HandlerFor app) where
getVaultData :: HandlerFor app (Maybe XRayVaultData)
getVaultData = Request -> Maybe XRayVaultData
vaultDataFromRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadHandler m => m Request
waiRequest
runDB
:: ( MonadUnliftIO m
, MonadTracer m
, MonadReader app m
, HasSqlPool app
, HasStatsClient app
)
=> SqlPersistT m a
-> m a
runDB :: forall (m :: * -> *) app a.
(MonadUnliftIO m, MonadTracer m, MonadReader app m, HasSqlPool app,
HasStatsClient app) =>
SqlPersistT m a -> m a
runDB SqlPersistT m a
action = do
SqlPool
pool <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall app. HasSqlPool app => app -> SqlPool
getSqlPool
Maybe XRayVaultData
mVaultData <- forall (m :: * -> *). MonadTracer m => m (Maybe XRayVaultData)
getVaultData
forall app (m :: * -> *) a.
(MonadReader app m, HasStatsClient app, MonadUnliftIO m) =>
(Gauges -> Gauge) -> m a -> m a
Stats.withGauge Gauges -> Gauge
Stats.dbConnections forall a b. (a -> b) -> a -> b
$
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> m a
runSqlPool (forall backend (m :: * -> *) a.
(backend ~ SqlBackend, MonadUnliftIO m) =>
Text -> XRayVaultData -> ReaderT backend m a -> Pool backend -> m a
runSqlPoolXRay Text
"runDB") Maybe XRayVaultData
mVaultData SqlPersistT m a
action SqlPool
pool
runSqlPoolXRay
:: (backend ~ SqlBackend, MonadUnliftIO m)
=> Text
-> XRayVaultData
-> ReaderT backend m a
-> Pool backend
-> m a
runSqlPoolXRay :: forall backend (m :: * -> *) a.
(backend ~ SqlBackend, MonadUnliftIO m) =>
Text -> XRayVaultData -> ReaderT backend m a -> Pool backend -> m a
runSqlPoolXRay Text
name XRayVaultData
vaultData ReaderT backend m a
action Pool backend
pool =
forall (m :: * -> *) a.
MonadUnliftIO m =>
XRayVaultData -> Text -> (XRaySegment -> XRaySegment) -> m a -> m a
traceXRaySubsegment' XRayVaultData
vaultData (Text
name forall a. Semigroup a => a -> a -> a
<> Text
" runSqlPool") forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$
\forall a. m a -> IO a
run -> forall a r. Pool a -> (a -> IO r) -> IO r
withResource Pool backend
pool forall a b. (a -> b) -> a -> b
$ \backend
backend -> do
let
sendTrace :: XRaySegment -> IO ()
sendTrace = XRayVaultData -> XRaySegment -> IO ()
atomicallyAddVaultDataSubsegment XRayVaultData
vaultData
stdGenIORef :: IORef StdGen
stdGenIORef = XRayVaultData -> IORef StdGen
xrayVaultDataStdGen XRayVaultData
vaultData
subsegmentName :: Text
subsegmentName = Text
name forall a. Semigroup a => a -> a -> a
<> Text
" query"
forall a. m a -> IO a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> backend -> m a
runSqlConn ReaderT backend m a
action
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(forall backend.
(IsPersistBackend backend, BaseBackend backend ~ SqlBackend) =>
(XRaySegment -> IO ())
-> IORef StdGen -> Text -> backend -> IO backend
xraySqlBackend XRaySegment -> IO ()
sendTrace IORef StdGen
stdGenIORef Text
subsegmentName backend
backend)