From 16ec24280d3851dd5b361eed413ca4621b0021f1 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Mon, 13 May 2024 12:29:50 +0200 Subject: feat(users/Profpatsch/whatcd-resolver): use PgFormatPool MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 Reviewed-by: Profpatsch Tested-by: BuildkiteCI --- .../my-prelude/src/Postgres/MonadPostgres.hs | 94 +++++++++++----------- users/Profpatsch/whatcd-resolver/src/AppT.hs | 3 +- .../whatcd-resolver/src/WhatcdResolver.hs | 3 +- 3 files changed, 50 insertions(+), 50 deletions(-) diff --git a/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs b/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs index b0f00de422e0..e5205f2651d4 100644 --- a/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs +++ b/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs @@ -366,7 +366,7 @@ handlePGException :: ( ToRow params, MonadUnliftIO m, MonadLogger m, - HasField "pgFormat" tools Tool + HasField "pgFormat" tools PgFormatPool ) => tools -> Text -> @@ -417,7 +417,7 @@ withPGTransaction connPool f = -- | `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. -- --- 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 { pool :: Pool PgFormatProcess, pgFormat :: Tool @@ -426,6 +426,7 @@ data PgFormatPool = PgFormatPool data PgFormatProcess = PgFormatProcess { stdinHdl :: Handle, stdoutHdl :: Handle, + stderrHdl :: Handle, procHdl :: ProcessHandle } @@ -446,7 +447,7 @@ initPgFormatPool tools = do -- unused resource time 100 -- number of resources - 3 + 10 ) -- fill the pool with resources @@ -461,8 +462,8 @@ destroyPgFormatPool :: PgFormatPool -> IO () 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. -withPgFormat :: PgFormatPool -> ByteString -> IO (ExitCode, ByteString) -withPgFormat pool sqlStatement = do +runPgFormat :: PgFormatPool -> ByteString -> IO (T3 "exitCode" ExitCode "formatted" ByteString "stderr" ByteString) +runPgFormat pool sqlStatement = do bracket (Pool.takeResource pool.pool) ( \(a, localPool) -> do @@ -473,13 +474,19 @@ withPgFormat pool sqlStatement = do Pool.putResource localPool new ) ( \(pgFmt, _localPool) -> do + putStderrLn "Running with warm pgformatter" ByteString.hPut pgFmt.stdinHdl sqlStatement -- close stdin to make pg_formatter format (it exits …) -- issue: https://github.com/darold/pgFormatter/issues/333 hClose pgFmt.stdinHdl formatted <- ByteString.hGetContents pgFmt.stdoutHdl + errs <- ByteString.hGetContents pgFmt.stderrHdl exitCode <- Process.waitForProcess pgFmt.procHdl - pure (exitCode, formatted) + pure $ + T3 + (label @"exitCode" exitCode) + (label @"formatted" formatted) + (label @"stderr" errs) ) runPGTransactionImpl :: @@ -495,7 +502,7 @@ runPGTransactionImpl zoom (Transaction transaction) = do unliftIO $ runReaderT transaction conn 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 DebugLogDatabaseQueries -> Query -> @@ -513,7 +520,7 @@ executeImpl zoomTools zoomDebugLogDatabaseQueries qry params = >>= toNumberOfRowsAffected "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 DebugLogDatabaseQueries -> Query -> @@ -530,7 +537,7 @@ executeImpl_ zoomTools zoomDebugLogDatabaseQueries qry = >>= toNumberOfRowsAffected "executeImpl_" 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 DebugLogDatabaseQueries -> Query -> @@ -557,7 +564,7 @@ toNumberOfRowsAffected functionName i64 = <&> label @"numberOfRowsAffected" 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 DebugLogDatabaseQueries -> Query -> @@ -578,7 +585,7 @@ foldRowsWithAccImpl :: ( ToRow params, MonadUnliftIO m, MonadLogger m, - HasField "pgFormat" tools Tool, + HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m ) => m tools -> @@ -612,7 +619,7 @@ foldRowsWithAccImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder ro ) pgFormatQueryNoParams' :: - (MonadIO m, MonadLogger m, HasField "pgFormat" tools Tool) => + (MonadIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool) => tools -> Query -> Transaction m Text @@ -648,7 +655,7 @@ queryWithImpl :: ( ToRow params, MonadUnliftIO m, MonadLogger m, - HasField "pgFormat" tools Tool, + HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m ) => m tools -> @@ -670,7 +677,7 @@ queryWithImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder fromRow) queryWithImpl_ :: ( MonadUnliftIO m, MonadLogger m, - HasField "pgFormat" tools Tool + HasField "pgFormat" tools PgFormatPool ) => m tools -> Query -> @@ -696,7 +703,7 @@ pgFormatQuery' :: ( MonadIO m, ToRow params, MonadLogger m, - HasField "pgFormat" tools Tool + HasField "pgFormat" tools PgFormatPool ) => tools -> Query -> @@ -710,7 +717,7 @@ pgFormatQueryMany' :: ( MonadIO m, ToRow params, MonadLogger m, - HasField "pgFormat" tools Tool + HasField "pgFormat" tools PgFormatPool ) => tools -> Query -> @@ -727,21 +734,32 @@ postgresToolsParser = label @"pgFormat" <$> readTool "pg_format" pgFormatQueryByteString :: ( MonadIO m, MonadLogger m, - HasField "pgFormat" tools Tool + HasField "pgFormat" tools PgFormatPool ) => tools -> ByteString -> m Text pgFormatQueryByteString tools queryBytes = do - do - (exitCode, stdout, stderr) <- - Process.readProcessWithExitCode - tools.pgFormat.toolPath - [ "--no-rcfile", - "-" - ] - (queryBytes & bytesToTextUtf8Lenient & textToString) - handlePgFormatExitCode exitCode stdout stderr queryBytes + res <- + liftIO $ + runPgFormat + tools.pgFormat + (queryBytes) + case res.exitCode of + ExitSuccess -> pure (res.formatted & bytesToTextUtf8Lenient) + 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 (res.formatted & bytesToTextUtf8Lenient & newError)) + :| [(nestedError "stderr" (singleError (res.stderr & bytesToTextUtf8Lenient & newError)))] + ) + ) + ) + logDebug [fmt|pg_format stdout: stderr|] + pure (queryBytes & bytesToTextUtf8Lenient) pgFormatStartCommandWaitForInput :: ( MonadIO m, @@ -752,7 +770,7 @@ pgFormatStartCommandWaitForInput :: m PgFormatProcess pgFormatStartCommandWaitForInput tools = do do - (Just stdinHdl, Just stdoutHdl, Nothing, procHdl) <- + (Just stdinHdl, Just stdoutHdl, Just stderrHdl, procHdl) <- Process.createProcess ( ( Process.proc tools.pgFormat.toolPath @@ -762,30 +780,12 @@ pgFormatStartCommandWaitForInput tools = do ) { Process.std_in = Process.CreatePipe, Process.std_out = Process.CreatePipe, - Process.std_err = Process.Inherit + Process.std_err = Process.CreatePipe } ) 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 = -- | Do not log the database queries DontLogDatabaseQueries @@ -805,7 +805,7 @@ traceQueryIfEnabled :: ( ToRow params, MonadUnliftIO m, MonadLogger m, - HasField "pgFormat" tools Tool, + HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m ) => tools -> diff --git a/users/Profpatsch/whatcd-resolver/src/AppT.hs b/users/Profpatsch/whatcd-resolver/src/AppT.hs index 7afd430745f6..abe8ccad4cd3 100644 --- a/users/Profpatsch/whatcd-resolver/src/AppT.hs +++ b/users/Profpatsch/whatcd-resolver/src/AppT.hs @@ -19,14 +19,13 @@ import OpenTelemetry.Trace.Monad qualified as Otel import PossehlAnalyticsPrelude import Postgres.MonadPostgres import System.IO qualified as IO -import Tool (Tool) import UnliftIO import Prelude hiding (span) data Context = Context { config :: Label "logDatabaseQueries" DebugLogDatabaseQueries, tracer :: Otel.Tracer, - pgFormat :: Tool, + pgFormat :: PgFormatPool, pgConnPool :: Pool Postgres.Connection, transmissionSessionId :: MVar ByteString } diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index d8e7889d3e98..1ec23e1fc707 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -639,7 +639,8 @@ httpTorrent span req = runAppWith :: AppT IO a -> IO (Either TmpPg.StartError a) 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 pgConnPool <- Pool.newPool $ -- cgit 1.4.1