{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE TypeOperators #-}

-- | Legacy version of "Freckle.App.Database" that still uses XRay
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 for reading 'XRayVaultData'
--
-- This is named the same as the OpenTelemetry class we'll use once we move to
-- that tracing system
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

-- | Run a Database action with connection stats and tracing
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

-- | @'runSqlPool'@ but with XRay tracing
runSqlPoolXRay
  :: (backend ~ SqlBackend, MonadUnliftIO m)
  => Text
  -- ^ Subsegment name
  --
  -- The top-level subsegment will be named @\"<this> runSqlPool\"@ and the,
  -- with a lower-level subsegment named @\"<this> query\"@.
  -> XRayVaultData
  -- ^ Vault data to trace with
  -> 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)