mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

feat(users/Profpatsch/whatcd-resolver): use PgFormatPool

Browse source 
It does chip of the init overhead of like 50–100ms, even though the
formatting still takes quite some time (up to 200ms for more complex
expressions).

Maybe we need some simplistic formatter in the future that just splits
on parens? It’s not an easy problem …

Change-Id: I2ce951e6b3c2dc56294b1bdab913480727b50f0b
Reviewed-on: https://cl.tvl.fyi/c/depot/+/11654
Autosubmit: Profpatsch <mail@profpatsch.de>
Reviewed-by: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI
This commit is contained in:
Profpatsch 2024-05-13 12:29:50 +02:00 committed by clbot
parent aa85a18723
commit 16ec24280d
3 changed files with 50 additions and 50 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

94
users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs
View file

@ -366,7 +366,7 @@ handlePGException ::
( ToRow params, ( ToRow params,
MonadUnliftIO m, MonadUnliftIO m,
MonadLogger m, MonadLogger m,
HasField "pgFormat" tools Tool HasField "pgFormat" tools PgFormatPool
) => ) =>
tools -> tools ->
Text -> Text ->
@ -417,7 +417,7 @@ withPGTransaction connPool f =
-- | `pg_formatter` is a perl script that does not support any kind of streaming. -- | `pg_formatter` is a perl script that does not support any kind of streaming.
-- Thus we initialize a pool with a bunch of these scripts running, waiting for input. This way we can have somewhat fast SQL formatting. -- Thus we initialize a pool with a bunch of these scripts running, waiting for input. This way we can have somewhat fast SQL formatting.
-- --
-- Call `initPgFormatPool` to initialize, then use `withPgFormat` to format some sql. -- Call `initPgFormatPool` to initialize, then use `runPgFormat` to format some sql.
data PgFormatPool = PgFormatPool data PgFormatPool = PgFormatPool
{ pool :: Pool PgFormatProcess, { pool :: Pool PgFormatProcess,
pgFormat :: Tool pgFormat :: Tool
@ -426,6 +426,7 @@ data PgFormatPool = PgFormatPool
data PgFormatProcess = PgFormatProcess data PgFormatProcess = PgFormatProcess
{ stdinHdl :: Handle, { stdinHdl :: Handle,
stdoutHdl :: Handle, stdoutHdl :: Handle,
stderrHdl :: Handle,
procHdl :: ProcessHandle procHdl :: ProcessHandle
} }
@ -446,7 +447,7 @@ initPgFormatPool tools = do
-- unused resource time -- unused resource time
100 100
-- number of resources -- number of resources
3 10
) )
-- fill the pool with resources -- fill the pool with resources
@ -461,8 +462,8 @@ destroyPgFormatPool :: PgFormatPool -> IO ()
destroyPgFormatPool pool = Pool.destroyAllResources pool.pool destroyPgFormatPool pool = Pool.destroyAllResources pool.pool
-- | Format the given SQL with pg_formatter. Will use the pool of already running formatters to speed up execution. -- | Format the given SQL with pg_formatter. Will use the pool of already running formatters to speed up execution.
withPgFormat :: PgFormatPool -> ByteString -> IO (ExitCode, ByteString) runPgFormat :: PgFormatPool -> ByteString -> IO (T3 "exitCode" ExitCode "formatted" ByteString "stderr" ByteString)
withPgFormat pool sqlStatement = do runPgFormat pool sqlStatement = do
bracket bracket
(Pool.takeResource pool.pool) (Pool.takeResource pool.pool)
( \(a, localPool) -> do ( \(a, localPool) -> do
@ -473,13 +474,19 @@ withPgFormat pool sqlStatement = do
Pool.putResource localPool new Pool.putResource localPool new
) )
( \(pgFmt, _localPool) -> do ( \(pgFmt, _localPool) -> do
putStderrLn "Running with warm pgformatter"
ByteString.hPut pgFmt.stdinHdl sqlStatement ByteString.hPut pgFmt.stdinHdl sqlStatement
-- close stdin to make pg_formatter format (it exits …) -- close stdin to make pg_formatter format (it exits …)
-- issue: https://github.com/darold/pgFormatter/issues/333 -- issue: https://github.com/darold/pgFormatter/issues/333
hClose pgFmt.stdinHdl hClose pgFmt.stdinHdl
formatted <- ByteString.hGetContents pgFmt.stdoutHdl formatted <- ByteString.hGetContents pgFmt.stdoutHdl
errs <- ByteString.hGetContents pgFmt.stderrHdl
exitCode <- Process.waitForProcess pgFmt.procHdl exitCode <- Process.waitForProcess pgFmt.procHdl
pure (exitCode, formatted) pure $
T3
(label @"exitCode" exitCode)
(label @"formatted" formatted)
(label @"stderr" errs)
) )
runPGTransactionImpl :: runPGTransactionImpl ::
@ -495,7 +502,7 @@ runPGTransactionImpl zoom (Transaction transaction) = do
unliftIO $ runReaderT transaction conn unliftIO $ runReaderT transaction conn
executeImpl :: executeImpl ::
(ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool, Otel.MonadTracer m) => (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) =>
m tools -> m tools ->
m DebugLogDatabaseQueries -> m DebugLogDatabaseQueries ->
Query -> Query ->
@ -513,7 +520,7 @@ executeImpl zoomTools zoomDebugLogDatabaseQueries qry params =
>>= toNumberOfRowsAffected "executeImpl" >>= toNumberOfRowsAffected "executeImpl"
executeImpl_ :: executeImpl_ ::
(MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool, Otel.MonadTracer m) => (MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) =>
m tools -> m tools ->
m DebugLogDatabaseQueries -> m DebugLogDatabaseQueries ->
Query -> Query ->
@ -530,7 +537,7 @@ executeImpl_ zoomTools zoomDebugLogDatabaseQueries qry =
>>= toNumberOfRowsAffected "executeImpl_" >>= toNumberOfRowsAffected "executeImpl_"
executeManyImpl :: executeManyImpl ::
(ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool, Otel.MonadTracer m) => (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) =>
m tools -> m tools ->
m DebugLogDatabaseQueries -> m DebugLogDatabaseQueries ->
Query -> Query ->
@ -557,7 +564,7 @@ toNumberOfRowsAffected functionName i64 =
<&> label @"numberOfRowsAffected" <&> label @"numberOfRowsAffected"
executeManyReturningWithImpl :: executeManyReturningWithImpl ::
(ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool, Otel.MonadTracer m) => (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) =>
m tools -> m tools ->
m DebugLogDatabaseQueries -> m DebugLogDatabaseQueries ->
Query -> Query ->
@ -578,7 +585,7 @@ foldRowsWithAccImpl ::
( ToRow params, ( ToRow params,
MonadUnliftIO m, MonadUnliftIO m,
MonadLogger m, MonadLogger m,
HasField "pgFormat" tools Tool, HasField "pgFormat" tools PgFormatPool,
Otel.MonadTracer m Otel.MonadTracer m
) => ) =>
m tools -> m tools ->
@ -612,7 +619,7 @@ foldRowsWithAccImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder ro
) )
pgFormatQueryNoParams' :: pgFormatQueryNoParams' ::
(MonadIO m, MonadLogger m, HasField "pgFormat" tools Tool) => (MonadIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool) =>
tools -> tools ->
Query -> Query ->
Transaction m Text Transaction m Text
@ -648,7 +655,7 @@ queryWithImpl ::
( ToRow params, ( ToRow params,
MonadUnliftIO m, MonadUnliftIO m,
MonadLogger m, MonadLogger m,
HasField "pgFormat" tools Tool, HasField "pgFormat" tools PgFormatPool,
Otel.MonadTracer m Otel.MonadTracer m
) => ) =>
m tools -> m tools ->
@ -670,7 +677,7 @@ queryWithImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder fromRow)
queryWithImpl_ :: queryWithImpl_ ::
( MonadUnliftIO m, ( MonadUnliftIO m,
MonadLogger m, MonadLogger m,
HasField "pgFormat" tools Tool HasField "pgFormat" tools PgFormatPool
) => ) =>
m tools -> m tools ->
Query -> Query ->
@ -696,7 +703,7 @@ pgFormatQuery' ::
( MonadIO m, ( MonadIO m,
ToRow params, ToRow params,
MonadLogger m, MonadLogger m,
HasField "pgFormat" tools Tool HasField "pgFormat" tools PgFormatPool
) => ) =>
tools -> tools ->
Query -> Query ->
@ -710,7 +717,7 @@ pgFormatQueryMany' ::
( MonadIO m, ( MonadIO m,
ToRow params, ToRow params,
MonadLogger m, MonadLogger m,
HasField "pgFormat" tools Tool HasField "pgFormat" tools PgFormatPool
) => ) =>
tools -> tools ->
Query -> Query ->
@ -727,21 +734,32 @@ postgresToolsParser = label @"pgFormat" <$> readTool "pg_format"
pgFormatQueryByteString :: pgFormatQueryByteString ::
( MonadIO m, ( MonadIO m,
MonadLogger m, MonadLogger m,
HasField "pgFormat" tools Tool HasField "pgFormat" tools PgFormatPool
) => ) =>
tools -> tools ->
ByteString -> ByteString ->
m Text m Text
pgFormatQueryByteString tools queryBytes = do pgFormatQueryByteString tools queryBytes = do
do res <-
(exitCode, stdout, stderr) <- liftIO $
Process.readProcessWithExitCode runPgFormat
tools.pgFormat.toolPath tools.pgFormat
[ "--no-rcfile", (queryBytes)
"-" case res.exitCode of
] ExitSuccess -> pure (res.formatted & bytesToTextUtf8Lenient)
(queryBytes & bytesToTextUtf8Lenient & textToString) ExitFailure status -> do
handlePgFormatExitCode exitCode stdout stderr queryBytes logWarn [fmt|pg_format failed with status {status} while formatting the query, using original query string. Is there a syntax error?|]
logDebug
( prettyErrorTree
( nestedMultiError
"pg_format output"
( nestedError "stdout" (singleError (res.formatted & bytesToTextUtf8Lenient & newError))
:| [(nestedError "stderr" (singleError (res.stderr & bytesToTextUtf8Lenient & newError)))]
)
)
)
logDebug [fmt|pg_format stdout: stderr|]
pure (queryBytes & bytesToTextUtf8Lenient)
pgFormatStartCommandWaitForInput :: pgFormatStartCommandWaitForInput ::
( MonadIO m, ( MonadIO m,
@ -752,7 +770,7 @@ pgFormatStartCommandWaitForInput ::
m PgFormatProcess m PgFormatProcess
pgFormatStartCommandWaitForInput tools = do pgFormatStartCommandWaitForInput tools = do
do do
(Just stdinHdl, Just stdoutHdl, Nothing, procHdl) <- (Just stdinHdl, Just stdoutHdl, Just stderrHdl, procHdl) <-
Process.createProcess Process.createProcess
( ( Process.proc ( ( Process.proc
tools.pgFormat.toolPath tools.pgFormat.toolPath
@ -762,30 +780,12 @@ pgFormatStartCommandWaitForInput tools = do
) )
{ Process.std_in = Process.CreatePipe, { Process.std_in = Process.CreatePipe,
Process.std_out = Process.CreatePipe, Process.std_out = Process.CreatePipe,
Process.std_err = Process.Inherit Process.std_err = Process.CreatePipe
} }
) )
pure PgFormatProcess {..} pure PgFormatProcess {..}
handlePgFormatExitCode :: (MonadLogger m) => ExitCode -> String -> String -> ByteString -> m Text
handlePgFormatExitCode exitCode stdout stderr queryBytes =
case exitCode of
ExitSuccess -> pure (stdout & stringToText)
ExitFailure status -> do
logWarn [fmt|pg_format failed with status {status} while formatting the query, using original query string. Is there a syntax error?|]
logDebug
( prettyErrorTree
( nestedMultiError
"pg_format output"
( nestedError "stdout" (singleError (stdout & stringToText & newError))
:| [(nestedError "stderr" (singleError (stderr & stringToText & newError)))]
)
)
)
logDebug [fmt|pg_format stdout: stderr|]
pure (queryBytes & bytesToTextUtf8Lenient)
data DebugLogDatabaseQueries data DebugLogDatabaseQueries
= -- | Do not log the database queries = -- | Do not log the database queries
DontLogDatabaseQueries DontLogDatabaseQueries
@ -805,7 +805,7 @@ traceQueryIfEnabled ::
( ToRow params, ( ToRow params,
MonadUnliftIO m, MonadUnliftIO m,
MonadLogger m, MonadLogger m,
HasField "pgFormat" tools Tool, HasField "pgFormat" tools PgFormatPool,
Otel.MonadTracer m Otel.MonadTracer m
) => ) =>
tools -> tools ->

3
users/Profpatsch/whatcd-resolver/src/AppT.hs
View file

@ -19,14 +19,13 @@ import OpenTelemetry.Trace.Monad qualified as Otel
import PossehlAnalyticsPrelude import PossehlAnalyticsPrelude
import Postgres.MonadPostgres import Postgres.MonadPostgres
import System.IO qualified as IO import System.IO qualified as IO
import Tool (Tool)
import UnliftIO import UnliftIO
import Prelude hiding (span) import Prelude hiding (span)
data Context = Context data Context = Context
{ config :: Label "logDatabaseQueries" DebugLogDatabaseQueries, { config :: Label "logDatabaseQueries" DebugLogDatabaseQueries,
tracer :: Otel.Tracer, tracer :: Otel.Tracer,
pgFormat :: Tool, pgFormat :: PgFormatPool,
pgConnPool :: Pool Postgres.Connection, pgConnPool :: Pool Postgres.Connection,
transmissionSessionId :: MVar ByteString transmissionSessionId :: MVar ByteString
} }

3
users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
View file

@ -639,7 +639,8 @@ httpTorrent span req =
runAppWith :: AppT IO a -> IO (Either TmpPg.StartError a) runAppWith :: AppT IO a -> IO (Either TmpPg.StartError a)
runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do
pgFormat <- readTools (label @"toolsEnvVar" "WHATCD_RESOLVER_TOOLS") (readTool "pg_format") tool <- readTools (label @"toolsEnvVar" "WHATCD_RESOLVER_TOOLS") (readTool "pg_format")
pgFormat <- initPgFormatPool (label @"pgFormat" tool)
let config = label @"logDatabaseQueries" LogDatabaseQueries let config = label @"logDatabaseQueries" LogDatabaseQueries
pgConnPool <- pgConnPool <-
Pool.newPool $ Pool.newPool $