fix(users/Profpatsch/whatcd-resolver): SQL formatting off

It turns out the pg_format thing is just too slow for my use-cases
most of the time, even when pooling the mf. Most queries stay 90%+ in
the perl script, even though they are very fast to execute on their
own, screwing up the traces a lot.

So instead I replace the `postgres-simple` quasi-quoter that strips
whitespace (and tends to screw up queries anyway) with a simple one
that just removes the outer indentation up to the first line.

Why did I spend so much time on pg_format haha

Change-Id: I911cd869deec68aa5cf430ff4d111b0662ec6d28
Reviewed-on: https://cl.tvl.fyi/c/depot/+/12138
Tested-by: BuildkiteCI
Reviewed-by: Profpatsch <mail@profpatsch.de>
This commit is contained in:
Profpatsch 2024-08-05 11:11:29 +02:00
parent 3202d008d5
commit 2510cd6a5c
4 changed files with 78 additions and 53 deletions

View file

@ -38,6 +38,7 @@ import Database.PostgreSQL.Simple.Types (Query (..))
import GHC.IO.Handle (Handle) import GHC.IO.Handle (Handle)
import GHC.Records (getField) import GHC.Records (getField)
import Label import Label
import Language.Haskell.TH.Quote (QuasiQuoter)
import OpenTelemetry.Trace.Core (NewEvent (newEventName)) import OpenTelemetry.Trace.Core (NewEvent (newEventName))
import OpenTelemetry.Trace.Core qualified as Otel hiding (inSpan, inSpan') import OpenTelemetry.Trace.Core qualified as Otel hiding (inSpan, inSpan')
import OpenTelemetry.Trace.Monad qualified as Otel import OpenTelemetry.Trace.Monad qualified as Otel
@ -45,6 +46,7 @@ import PossehlAnalyticsPrelude
import Postgres.Decoder import Postgres.Decoder
import Postgres.Decoder qualified as Dec import Postgres.Decoder qualified as Dec
import Pretty (showPretty) import Pretty (showPretty)
import PyF qualified
import Seconds import Seconds
import System.Exit (ExitCode (..)) import System.Exit (ExitCode (..))
import Tool import Tool
@ -140,6 +142,10 @@ class (Monad m) => MonadPostgres (m :: Type -> Type) where
-- Only handlers should run transactions. -- Only handlers should run transactions.
runTransaction :: Transaction m a -> m a runTransaction :: Transaction m a -> m a
-- | Quasi-Quoter for multi-line SQL literals. Trims leading whitespace up to the least-indented line.
sql :: QuasiQuoter
sql = PyF.fmtTrim
-- | Run a query, passing parameters. Prefer 'queryWith' if possible. -- | Run a query, passing parameters. Prefer 'queryWith' if possible.
query :: query ::
forall m params r. forall m params r.
@ -397,7 +403,7 @@ handlePGException tools queryType query' params io = do
throwErr throwErr
( singleError [fmt|Query Type: {queryType}|] ( singleError [fmt|Query Type: {queryType}|]
:| [ nestedError "Exception" (exc & showPretty & newError & singleError), :| [ nestedError "Exception" (exc & showPretty & newError & singleError),
nestedError "Query" (formattedQuery & newError & singleError) nestedError "Query" (formattedQuery & bytesToTextUtf8Lenient & newError & singleError)
] ]
) )
logFormatException :: FormatError -> Transaction m a logFormatException :: FormatError -> Transaction m a
@ -529,16 +535,16 @@ runPGTransactionImpl zoom (Transaction transaction) = do
executeImpl :: executeImpl ::
(ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) => (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) =>
m tools -> m tools ->
m DebugLogDatabaseQueries -> m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries) ->
Query -> Query ->
params -> params ->
Transaction m (Label "numberOfRowsAffected" Natural) Transaction m (Label "numberOfRowsAffected" Natural)
{-# INLINE executeImpl #-} {-# INLINE executeImpl #-}
executeImpl zoomTools zoomDebugLogDatabaseQueries qry params = executeImpl zoomTools zoomDbOptions qry params =
Otel.inSpan' "Postgres Query (execute)" Otel.defaultSpanArguments $ \span -> do Otel.inSpan' "Postgres Query (execute)" Otel.defaultSpanArguments $ \span -> do
tools <- lift @Transaction zoomTools tools <- lift @Transaction zoomTools
logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
traceQueryIfEnabled tools span logDatabaseQueries qry (HasSingleParam params) traceQueryIfEnabled tools span logDatabaseQueries prettyQuery qry (HasSingleParam params)
conn <- Transaction ask conn <- Transaction ask
PG.execute conn qry params PG.execute conn qry params
& handlePGException tools "execute" qry (Left params) & handlePGException tools "execute" qry (Left params)
@ -547,15 +553,15 @@ executeImpl zoomTools zoomDebugLogDatabaseQueries qry params =
executeImpl_ :: executeImpl_ ::
(MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) => (MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) =>
m tools -> m tools ->
m DebugLogDatabaseQueries -> m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries) ->
Query -> Query ->
Transaction m (Label "numberOfRowsAffected" Natural) Transaction m (Label "numberOfRowsAffected" Natural)
{-# INLINE executeImpl_ #-} {-# INLINE executeImpl_ #-}
executeImpl_ zoomTools zoomDebugLogDatabaseQueries qry = executeImpl_ zoomTools zoomDbOptions qry =
Otel.inSpan' "Postgres Query (execute)" Otel.defaultSpanArguments $ \span -> do Otel.inSpan' "Postgres Query (execute)" Otel.defaultSpanArguments $ \span -> do
tools <- lift @Transaction zoomTools tools <- lift @Transaction zoomTools
logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
traceQueryIfEnabled @() tools span logDatabaseQueries qry HasNoParams traceQueryIfEnabled @() tools span logDatabaseQueries prettyQuery qry HasNoParams
conn <- Transaction ask conn <- Transaction ask
PG.execute_ conn qry PG.execute_ conn qry
& handlePGException tools "execute_" qry (Left ()) & handlePGException tools "execute_" qry (Left ())
@ -564,15 +570,15 @@ executeImpl_ zoomTools zoomDebugLogDatabaseQueries qry =
executeManyImpl :: executeManyImpl ::
(ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) => (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) =>
m tools -> m tools ->
m DebugLogDatabaseQueries -> m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries) ->
Query -> Query ->
NonEmpty params -> NonEmpty params ->
Transaction m (Label "numberOfRowsAffected" Natural) Transaction m (Label "numberOfRowsAffected" Natural)
executeManyImpl zoomTools zoomDebugLogDatabaseQueries qry params = executeManyImpl zoomTools zoomDbOptions qry params =
Otel.inSpan' "Postgres Query (executeMany)" Otel.defaultSpanArguments $ \span -> do Otel.inSpan' "Postgres Query (executeMany)" Otel.defaultSpanArguments $ \span -> do
tools <- lift @Transaction zoomTools tools <- lift @Transaction zoomTools
logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
traceQueryIfEnabled tools span logDatabaseQueries qry (HasMultiParams params) traceQueryIfEnabled tools span logDatabaseQueries prettyQuery qry (HasMultiParams params)
conn <- Transaction ask conn <- Transaction ask
PG.executeMany conn qry (params & toList) PG.executeMany conn qry (params & toList)
& handlePGException tools "executeMany" qry (Right params) & handlePGException tools "executeMany" qry (Right params)
@ -591,17 +597,17 @@ toNumberOfRowsAffected functionName i64 =
executeManyReturningWithImpl :: executeManyReturningWithImpl ::
(ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) => (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) =>
m tools -> m tools ->
m DebugLogDatabaseQueries -> m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries) ->
Query -> Query ->
NonEmpty params -> NonEmpty params ->
Decoder r -> Decoder r ->
Transaction m [r] Transaction m [r]
{-# INLINE executeManyReturningWithImpl #-} {-# INLINE executeManyReturningWithImpl #-}
executeManyReturningWithImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder fromRow) = do executeManyReturningWithImpl zoomTools zoomDbOptions qry params (Decoder fromRow) = do
Otel.inSpan' "Postgres Query (executeManyReturning)" Otel.defaultSpanArguments $ \span -> do Otel.inSpan' "Postgres Query (executeManyReturning)" Otel.defaultSpanArguments $ \span -> do
tools <- lift @Transaction zoomTools tools <- lift @Transaction zoomTools
logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
traceQueryIfEnabled tools span logDatabaseQueries qry (HasMultiParams params) traceQueryIfEnabled tools span logDatabaseQueries prettyQuery qry (HasMultiParams params)
conn <- Transaction ask conn <- Transaction ask
PG.returningWith fromRow conn qry (params & toList) PG.returningWith fromRow conn qry (params & toList)
& handlePGException tools "executeManyReturning" qry (Right params) & handlePGException tools "executeManyReturning" qry (Right params)
@ -614,7 +620,7 @@ foldRowsWithAccImpl ::
Otel.MonadTracer m Otel.MonadTracer m
) => ) =>
m tools -> m tools ->
m DebugLogDatabaseQueries -> m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries) ->
Query -> Query ->
params -> params ->
Decoder row -> Decoder row ->
@ -622,11 +628,11 @@ foldRowsWithAccImpl ::
(a -> row -> Transaction m a) -> (a -> row -> Transaction m a) ->
Transaction m a Transaction m a
{-# INLINE foldRowsWithAccImpl #-} {-# INLINE foldRowsWithAccImpl #-}
foldRowsWithAccImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder rowParser) accumulator f = do foldRowsWithAccImpl zoomTools zoomDbOptions qry params (Decoder rowParser) accumulator f = do
Otel.inSpan' "Postgres Query (foldRowsWithAcc)" Otel.defaultSpanArguments $ \span -> do Otel.inSpan' "Postgres Query (foldRowsWithAcc)" Otel.defaultSpanArguments $ \span -> do
tools <- lift @Transaction zoomTools tools <- lift @Transaction zoomTools
logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
traceQueryIfEnabled tools span logDatabaseQueries qry (HasSingleParam params) traceQueryIfEnabled tools span logDatabaseQueries prettyQuery qry (HasSingleParam params)
conn <- Transaction ask conn <- Transaction ask
withRunInIO withRunInIO
( \runInIO -> ( \runInIO ->
@ -647,7 +653,7 @@ pgFormatQueryNoParams' ::
(MonadIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool) => (MonadIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool) =>
tools -> tools ->
Query -> Query ->
Transaction m Text Transaction m ByteString
pgFormatQueryNoParams' tools q = pgFormatQueryNoParams' tools q =
lift $ pgFormatQueryByteString tools q.fromQuery lift $ pgFormatQueryByteString tools q.fromQuery
@ -684,17 +690,17 @@ queryWithImpl ::
Otel.MonadTracer m Otel.MonadTracer m
) => ) =>
m tools -> m tools ->
m DebugLogDatabaseQueries -> m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries) ->
Query -> Query ->
params -> params ->
Decoder r -> Decoder r ->
Transaction m [r] Transaction m [r]
{-# INLINE queryWithImpl #-} {-# INLINE queryWithImpl #-}
queryWithImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder fromRow) = do queryWithImpl zoomTools zoomDbOptions qry params (Decoder fromRow) = do
Otel.inSpan' "Postgres Query (queryWith)" Otel.defaultSpanArguments $ \span -> do Otel.inSpan' "Postgres Query (queryWith)" Otel.defaultSpanArguments $ \span -> do
tools <- lift @Transaction zoomTools tools <- lift @Transaction zoomTools
logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
traceQueryIfEnabled tools span logDatabaseQueries qry (HasSingleParam params) traceQueryIfEnabled tools span logDatabaseQueries prettyQuery qry (HasSingleParam params)
conn <- Transaction ask conn <- Transaction ask
PG.queryWith fromRow conn qry params PG.queryWith fromRow conn qry params
& handlePGException tools "query" qry (Left params) & handlePGException tools "query" qry (Left params)
@ -733,7 +739,7 @@ pgFormatQuery' ::
tools -> tools ->
Query -> Query ->
params -> params ->
Transaction m Text Transaction m ByteString
pgFormatQuery' tools q p = pgFormatQuery' tools q p =
pgFormatQuery q p pgFormatQuery q p
>>= lift . pgFormatQueryByteString tools >>= lift . pgFormatQueryByteString tools
@ -747,7 +753,7 @@ pgFormatQueryMany' ::
tools -> tools ->
Query -> Query ->
NonEmpty params -> NonEmpty params ->
Transaction m Text Transaction m ByteString
pgFormatQueryMany' tools q p = pgFormatQueryMany' tools q p =
pgFormatQueryMany q p pgFormatQueryMany q p
>>= lift . pgFormatQueryByteString tools >>= lift . pgFormatQueryByteString tools
@ -763,7 +769,7 @@ pgFormatQueryByteString ::
) => ) =>
tools -> tools ->
ByteString -> ByteString ->
m Text m ByteString
pgFormatQueryByteString tools queryBytes = do pgFormatQueryByteString tools queryBytes = do
res <- res <-
liftIO $ liftIO $
@ -771,7 +777,7 @@ pgFormatQueryByteString tools queryBytes = do
tools.pgFormat tools.pgFormat
(queryBytes) (queryBytes)
case res.exitCode of case res.exitCode of
ExitSuccess -> pure (res.formatted & bytesToTextUtf8Lenient) ExitSuccess -> pure (res.formatted)
ExitFailure status -> do ExitFailure status -> do
logWarn [fmt|pg_format failed with status {status} while formatting the query, using original query string. Is there a syntax error?|] logWarn [fmt|pg_format failed with status {status} while formatting the query, using original query string. Is there a syntax error?|]
logDebug logDebug
@ -784,7 +790,7 @@ pgFormatQueryByteString tools queryBytes = do
) )
) )
logDebug [fmt|pg_format stdout: stderr|] logDebug [fmt|pg_format stdout: stderr|]
pure (queryBytes & bytesToTextUtf8Lenient) pure (queryBytes)
pgFormatStartCommandWaitForInput :: pgFormatStartCommandWaitForInput ::
( MonadIO m, ( MonadIO m,
@ -821,6 +827,14 @@ data DebugLogDatabaseQueries
LogDatabaseQueriesAndExplain LogDatabaseQueriesAndExplain
deriving stock (Show, Enum, Bounded) deriving stock (Show, Enum, Bounded)
-- | Whether to pipe database queries thru `pg_format` before logging them. This takes a long (long! 200ms+) time per query, so should only be used in debugging environments where speed is not an issue.
data PrettyPrintDatabaseQueries
= -- | Do not pretty-print database querios
DontPrettyPrintDatabaseQueries
| -- | Pretty-print database queries, slow
PrettyPrintDatabaseQueries
deriving stock (Show, Enum, Bounded)
data HasQueryParams param data HasQueryParams param
= HasNoParams = HasNoParams
| HasSingleParam param | HasSingleParam param
@ -837,12 +851,15 @@ traceQueryIfEnabled ::
tools -> tools ->
Otel.Span -> Otel.Span ->
DebugLogDatabaseQueries -> DebugLogDatabaseQueries ->
PrettyPrintDatabaseQueries ->
Query -> Query ->
HasQueryParams params -> HasQueryParams params ->
Transaction m () Transaction m ()
traceQueryIfEnabled tools span logDatabaseQueries qry params = do traceQueryIfEnabled tools span logDatabaseQueries prettyQuery qry params = do
-- In case we have query logging enabled, we want to do that -- In case we have query logging enabled, we want to do that
let formattedQuery = do let formattedQuery = case prettyQuery of
DontPrettyPrintDatabaseQueries -> pure qry.fromQuery
PrettyPrintDatabaseQueries -> do
withEvent withEvent
span span
"Query Format start" "Query Format start"
@ -856,7 +873,7 @@ traceQueryIfEnabled tools span logDatabaseQueries qry params = do
Otel.addAttributes Otel.addAttributes
span span
$ HashMap.fromList $ HashMap.fromList
$ ( ("_.postgres.query", Otel.toAttribute @Text errs.query) $ ( ("_.postgres.query", Otel.toAttribute @Text (errs.query & bytesToTextUtf8Lenient))
: ( errs.explain : ( errs.explain
& \case & \case
Nothing -> [] Nothing -> []
@ -872,7 +889,7 @@ traceQueryIfEnabled tools span logDatabaseQueries qry params = do
<> ( <> (
-- TODO: this is not nice, but the only way to get the `executeMany` form to work with this -- TODO: this is not nice, but the only way to get the `executeMany` form to work with this
-- because we need the query with all elements already interpolated. -- because we need the query with all elements already interpolated.
Query (q & textToBytesUtf8) Query q
) )
) )
(Dec.fromField @Text) (Dec.fromField @Text)

View file

@ -25,7 +25,7 @@ import UnliftIO
import Prelude hiding (span) import Prelude hiding (span)
data Context = Context data Context = Context
{ config :: Label "logDatabaseQueries" DebugLogDatabaseQueries, { config :: T2 "logDatabaseQueries" DebugLogDatabaseQueries "prettyPrintDatabaseQueries" PrettyPrintDatabaseQueries,
tracer :: Otel.Tracer, tracer :: Otel.Tracer,
pgFormat :: PgFormatPool, pgFormat :: PgFormatPool,
pgConnPool :: Pool Postgres.Connection, pgConnPool :: Pool Postgres.Connection,
@ -147,15 +147,18 @@ recordException span dat = liftIO $ do
-- * Postgres -- * Postgres
instance (MonadThrow m, MonadUnliftIO m) => MonadPostgres (AppT m) where instance (MonadThrow m, MonadUnliftIO m) => MonadPostgres (AppT m) where
execute = executeImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries)) execute = executeImpl (AppT ask) dbConfig
executeMany = executeManyImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries)) executeMany = executeManyImpl (AppT ask) dbConfig
executeManyReturningWith = executeManyReturningWithImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries)) executeManyReturningWith = executeManyReturningWithImpl (AppT ask) dbConfig
queryWith = queryWithImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries)) queryWith = queryWithImpl (AppT ask) dbConfig
queryWith_ = queryWithImpl_ (AppT ask) queryWith_ = queryWithImpl_ (AppT ask)
foldRowsWithAcc = foldRowsWithAccImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries)) foldRowsWithAcc = foldRowsWithAccImpl (AppT ask) dbConfig
runTransaction = runPGTransaction runTransaction = runPGTransaction
dbConfig :: (Monad m) => AppT m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries)
dbConfig = AppT $ asks (\c -> (c.config.logDatabaseQueries, c.config.prettyPrintDatabaseQueries))
runPGTransaction :: (MonadUnliftIO m) => Transaction (AppT m) a -> AppT m a runPGTransaction :: (MonadUnliftIO m) => Transaction (AppT m) a -> AppT m a
runPGTransaction (Transaction transaction) = do runPGTransaction (Transaction transaction) = do
pool <- AppT ask <&> (.pgConnPool) pool <- AppT ask <&> (.pgConnPool)

View file

@ -12,7 +12,6 @@ import Data.Aeson.KeyMap qualified as KeyMap
import Data.Error.Tree import Data.Error.Tree
import Data.List qualified as List import Data.List qualified as List
import Database.PostgreSQL.Simple (Binary (Binary), Only (..)) import Database.PostgreSQL.Simple (Binary (Binary), Only (..))
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.Types (PGArray (PGArray)) import Database.PostgreSQL.Simple.Types (PGArray (PGArray))
import FieldParser qualified as Field import FieldParser qualified as Field
import Http qualified import Http qualified

View file

@ -18,7 +18,6 @@ import Data.Map.Strict qualified as Map
import Data.Pool qualified as Pool import Data.Pool qualified as Pool
import Data.Text qualified as Text import Data.Text qualified as Text
import Database.PostgreSQL.Simple qualified as Postgres import Database.PostgreSQL.Simple qualified as Postgres
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.Types (PGArray (PGArray)) import Database.PostgreSQL.Simple.Types (PGArray (PGArray))
import Database.Postgres.Temp qualified as TmpPg import Database.Postgres.Temp qualified as TmpPg
import FieldParser (FieldParser, FieldParser' (..)) import FieldParser (FieldParser, FieldParser' (..))
@ -778,7 +777,14 @@ runAppWith :: AppT IO a -> IO (Either TmpPg.StartError a)
runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do
tool <- readTools (label @"toolsEnvVar" "WHATCD_RESOLVER_TOOLS") (readTool "pg_format") tool <- readTools (label @"toolsEnvVar" "WHATCD_RESOLVER_TOOLS") (readTool "pg_format")
pgFormat <- initPgFormatPool (label @"pgFormat" tool) pgFormat <- initPgFormatPool (label @"pgFormat" tool)
let config = label @"logDatabaseQueries" LogDatabaseQueries prettyPrintDatabaseQueries <-
Env.lookupEnv "WHATCD_RESOLVER_PRETTY_PRINT_DATABASE_QUERIES" <&> \case
Just _ -> PrettyPrintDatabaseQueries
Nothing -> DontPrettyPrintDatabaseQueries
let config =
T2
(label @"logDatabaseQueries" LogDatabaseQueries)
(label @"prettyPrintDatabaseQueries" prettyPrintDatabaseQueries)
pgConnPool <- pgConnPool <-
Pool.newPool $ Pool.newPool $
Pool.defaultPoolConfig Pool.defaultPoolConfig