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

-- | Legacy version of "Freckle.App.Database" that still uses XRay
module Freckle.App.Database.XRay
  ( -- * Running transactions
    MonadSqlTx (..)
  , runDB
  , runDBSimple

    -- * Running queries
  , SqlBackend
  , HasSqlBackend (..)
  , MonadSqlBackend (..)
  , liftSql

    -- * Telemetry
  , MonadTracer (..)
  , HasStatsClient

    -- * Connection pools
  , HasSqlPool (..)
  , SqlPool
  , makePostgresPool
  , makePostgresPoolWith

    -- * Setup
  , 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 (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 (Request -> Maybe XRayVaultData)
-> HandlerFor app Request -> HandlerFor app (Maybe XRayVaultData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandlerFor app Request
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 <- (app -> SqlPool) -> m SqlPool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks app -> SqlPool
forall app. HasSqlPool app => app -> SqlPool
getSqlPool
  Maybe XRayVaultData
mVaultData <- m (Maybe XRayVaultData)
forall (m :: * -> *). MonadTracer m => m (Maybe XRayVaultData)
getVaultData
  (Gauges -> Gauge) -> m a -> m a
forall app (m :: * -> *) a.
(MonadReader app m, HasStatsClient app, MonadUnliftIO m) =>
(Gauges -> Gauge) -> m a -> m a
Stats.withGauge Gauges -> Gauge
Stats.dbConnections (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$
    (SqlPersistT m a -> SqlPool -> m a)
-> (XRayVaultData -> SqlPersistT m a -> SqlPool -> m a)
-> Maybe XRayVaultData
-> SqlPersistT m a
-> SqlPool
-> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SqlPersistT m a -> SqlPool -> m a
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> m a
runSqlPool (Text -> XRayVaultData -> SqlPersistT m a -> SqlPool -> m a
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 =
  XRayVaultData -> Text -> (XRaySegment -> XRaySegment) -> m a -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
XRayVaultData -> Text -> (XRaySegment -> XRaySegment) -> m a -> m a
traceXRaySubsegment' XRayVaultData
vaultData (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" runSqlPool") XRaySegment -> XRaySegment
forall a. a -> a
id (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$
    ((forall a. m a -> IO a) -> IO a) -> m a
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$
      \forall a. m a -> IO a
run -> Pool backend -> (backend -> IO a) -> IO a
forall a r. Pool a -> (a -> IO r) -> IO r
withResource Pool backend
pool ((backend -> IO a) -> IO a) -> (backend -> IO a) -> IO a
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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" query"
        m a -> IO a
forall a. m a -> IO a
run (m a -> IO a) -> (backend -> m a) -> backend -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT backend m a -> backend -> m a
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> backend -> m a
runSqlConn ReaderT backend m a
action
          (backend -> IO a) -> IO backend -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO backend -> IO backend
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
            ((XRaySegment -> IO ())
-> IORef StdGen -> Text -> backend -> IO backend
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)