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>
2024-08-05 11:11:29 +02:00 · 2024-08-05 11:11:29 +02:00 · 2510cd6a5c
commit 2510cd6a5c
parent 3202d008d5
4 changed files with 78 additions and 53 deletions
--- a/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs
+++ b/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs
@ -38,6 +38,7 @@ import Database.PostgreSQL.Simple.Types (Query (..))
 import GHC.IO.Handle (Handle)
 import GHC.Records (getField)
 import Label
+import Language.Haskell.TH.Quote (QuasiQuoter)
 import OpenTelemetry.Trace.Core (NewEvent (newEventName))
 import OpenTelemetry.Trace.Core qualified as Otel hiding (inSpan, inSpan')
 import OpenTelemetry.Trace.Monad qualified as Otel
@ -45,6 +46,7 @@ import PossehlAnalyticsPrelude
 import Postgres.Decoder
 import Postgres.Decoder qualified as Dec
 import Pretty (showPretty)
+import PyF qualified
 import Seconds
 import System.Exit (ExitCode (..))
 import Tool
@ -140,6 +142,10 @@ class (Monad m) => MonadPostgres (m :: Type -> Type) where
  -- Only handlers should run transactions.
  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.
 query ::
  forall m params r.
@ -397,7 +403,7 @@ handlePGException tools queryType query' params io = do
      throwErr
        ( singleError [fmt|Query Type: {queryType}|]
            :| [ nestedError "Exception" (exc & showPretty & newError & singleError),
-                 nestedError "Query" (formattedQuery & newError & singleError)
+                 nestedError "Query" (formattedQuery & bytesToTextUtf8Lenient & newError & singleError)
               ]
        )
    logFormatException :: FormatError -> Transaction m a
@ -529,16 +535,16 @@ runPGTransactionImpl zoom (Transaction transaction) = do
 executeImpl ::
  (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) =>
  m tools ->
-  m DebugLogDatabaseQueries ->
+  m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries) ->
  Query ->
  params ->
  Transaction m (Label "numberOfRowsAffected" Natural)
 {-# INLINE executeImpl #-}
-executeImpl zoomTools zoomDebugLogDatabaseQueries qry params =
+executeImpl zoomTools zoomDbOptions qry params =
  Otel.inSpan' "Postgres Query (execute)" Otel.defaultSpanArguments $ \span -> do
    tools <- lift @Transaction zoomTools
-    logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries
-    traceQueryIfEnabled tools span logDatabaseQueries qry (HasSingleParam params)
+    (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
+    traceQueryIfEnabled tools span logDatabaseQueries prettyQuery qry (HasSingleParam params)
    conn <- Transaction ask
    PG.execute conn qry params
      & handlePGException tools "execute" qry (Left params)
@ -547,15 +553,15 @@ executeImpl zoomTools zoomDebugLogDatabaseQueries qry params =
 executeImpl_ ::
  (MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) =>
  m tools ->
-  m DebugLogDatabaseQueries ->
+  m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries) ->
  Query ->
  Transaction m (Label "numberOfRowsAffected" Natural)
 {-# INLINE executeImpl_ #-}
-executeImpl_ zoomTools zoomDebugLogDatabaseQueries qry =
+executeImpl_ zoomTools zoomDbOptions qry =
  Otel.inSpan' "Postgres Query (execute)" Otel.defaultSpanArguments $ \span -> do
    tools <- lift @Transaction zoomTools
-    logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries
-    traceQueryIfEnabled @() tools span logDatabaseQueries qry HasNoParams
+    (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
+    traceQueryIfEnabled @() tools span logDatabaseQueries prettyQuery qry HasNoParams
    conn <- Transaction ask
    PG.execute_ conn qry
      & handlePGException tools "execute_" qry (Left ())
@ -564,15 +570,15 @@ executeImpl_ zoomTools zoomDebugLogDatabaseQueries qry =
 executeManyImpl ::
  (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) =>
  m tools ->
-  m DebugLogDatabaseQueries ->
+  m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries) ->
  Query ->
  NonEmpty params ->
  Transaction m (Label "numberOfRowsAffected" Natural)
-executeManyImpl zoomTools zoomDebugLogDatabaseQueries qry params =
+executeManyImpl zoomTools zoomDbOptions qry params =
  Otel.inSpan' "Postgres Query (executeMany)" Otel.defaultSpanArguments $ \span -> do
    tools <- lift @Transaction zoomTools
-    logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries
-    traceQueryIfEnabled tools span logDatabaseQueries qry (HasMultiParams params)
+    (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
+    traceQueryIfEnabled tools span logDatabaseQueries prettyQuery qry (HasMultiParams params)
    conn <- Transaction ask
    PG.executeMany conn qry (params & toList)
      & handlePGException tools "executeMany" qry (Right params)
@ -591,17 +597,17 @@ toNumberOfRowsAffected functionName i64 =
 executeManyReturningWithImpl ::
  (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) =>
  m tools ->
-  m DebugLogDatabaseQueries ->
+  m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries) ->
  Query ->
  NonEmpty params ->
  Decoder r ->
  Transaction m [r]
 {-# 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
    tools <- lift @Transaction zoomTools
-    logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries
-    traceQueryIfEnabled tools span logDatabaseQueries qry (HasMultiParams params)
+    (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
+    traceQueryIfEnabled tools span logDatabaseQueries prettyQuery qry (HasMultiParams params)
    conn <- Transaction ask
    PG.returningWith fromRow conn qry (params & toList)
      & handlePGException tools "executeManyReturning" qry (Right params)
@ -614,7 +620,7 @@ foldRowsWithAccImpl ::
    Otel.MonadTracer m
  ) =>
  m tools ->
-  m DebugLogDatabaseQueries ->
+  m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries) ->
  Query ->
  params ->
  Decoder row ->
@ -622,11 +628,11 @@ foldRowsWithAccImpl ::
  (a -> row -> Transaction m a) ->
  Transaction m a
 {-# 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
    tools <- lift @Transaction zoomTools
-    logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries
-    traceQueryIfEnabled tools span logDatabaseQueries qry (HasSingleParam params)
+    (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
+    traceQueryIfEnabled tools span logDatabaseQueries prettyQuery qry (HasSingleParam params)
    conn <- Transaction ask
    withRunInIO
      ( \runInIO ->
@ -647,7 +653,7 @@ pgFormatQueryNoParams' ::
  (MonadIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool) =>
  tools ->
  Query ->
-  Transaction m Text
+  Transaction m ByteString
 pgFormatQueryNoParams' tools q =
  lift $ pgFormatQueryByteString tools q.fromQuery

@ -684,17 +690,17 @@ queryWithImpl ::
    Otel.MonadTracer m
  ) =>
  m tools ->
-  m DebugLogDatabaseQueries ->
+  m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries) ->
  Query ->
  params ->
  Decoder r ->
  Transaction m [r]
 {-# 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
    tools <- lift @Transaction zoomTools
-    logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries
-    traceQueryIfEnabled tools span logDatabaseQueries qry (HasSingleParam params)
+    (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
+    traceQueryIfEnabled tools span logDatabaseQueries prettyQuery qry (HasSingleParam params)
    conn <- Transaction ask
    PG.queryWith fromRow conn qry params
      & handlePGException tools "query" qry (Left params)
@ -733,7 +739,7 @@ pgFormatQuery' ::
  tools ->
  Query ->
  params ->
-  Transaction m Text
+  Transaction m ByteString
 pgFormatQuery' tools q p =
  pgFormatQuery q p
    >>= lift . pgFormatQueryByteString tools
@ -747,7 +753,7 @@ pgFormatQueryMany' ::
  tools ->
  Query ->
  NonEmpty params ->
-  Transaction m Text
+  Transaction m ByteString
 pgFormatQueryMany' tools q p =
  pgFormatQueryMany q p
    >>= lift . pgFormatQueryByteString tools
@ -763,7 +769,7 @@ pgFormatQueryByteString ::
  ) =>
  tools ->
  ByteString ->
-  m Text
+  m ByteString
 pgFormatQueryByteString tools queryBytes = do
  res <-
    liftIO $
@ -771,7 +777,7 @@ pgFormatQueryByteString tools queryBytes = do
        tools.pgFormat
        (queryBytes)
  case res.exitCode of
-    ExitSuccess -> pure (res.formatted & bytesToTextUtf8Lenient)
+    ExitSuccess -> pure (res.formatted)
    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
@ -784,7 +790,7 @@ pgFormatQueryByteString tools queryBytes = do
            )
        )
      logDebug [fmt|pg_format stdout: stderr|]
-      pure (queryBytes & bytesToTextUtf8Lenient)
+      pure (queryBytes)

 pgFormatStartCommandWaitForInput ::
  ( MonadIO m,
@ -821,6 +827,14 @@ data DebugLogDatabaseQueries
    LogDatabaseQueriesAndExplain
  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
  = HasNoParams
  | HasSingleParam param
@ -837,26 +851,29 @@ traceQueryIfEnabled ::
  tools ->
  Otel.Span ->
  DebugLogDatabaseQueries ->
+  PrettyPrintDatabaseQueries ->
  Query ->
  HasQueryParams params ->
  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
-  let formattedQuery = do
-        withEvent
-          span
-          "Query Format start"
-          "Query Format end"
-          $ case params of
-            HasNoParams -> pgFormatQueryNoParams' tools qry
-            HasSingleParam p -> pgFormatQuery' tools qry p
-            HasMultiParams ps -> pgFormatQueryMany' tools qry ps
+  let formattedQuery = case prettyQuery of
+        DontPrettyPrintDatabaseQueries -> pure qry.fromQuery
+        PrettyPrintDatabaseQueries -> do
+          withEvent
+            span
+            "Query Format start"
+            "Query Format end"
+            $ case params of
+              HasNoParams -> pgFormatQueryNoParams' tools qry
+              HasSingleParam p -> pgFormatQuery' tools qry p
+              HasMultiParams ps -> pgFormatQueryMany' tools qry ps

  let doLog errs =
        Otel.addAttributes
          span
          $ HashMap.fromList
-          $ ( ("_.postgres.query", Otel.toAttribute @Text errs.query)
+          $ ( ("_.postgres.query", Otel.toAttribute @Text (errs.query & bytesToTextUtf8Lenient))
                : ( errs.explain
                      & \case
                        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
                     -- because we need the query with all elements already interpolated.
-                     Query (q & textToBytesUtf8)
+                     Query q
                   )
            )
            (Dec.fromField @Text)
--- a/users/Profpatsch/whatcd-resolver/src/AppT.hs
+++ b/users/Profpatsch/whatcd-resolver/src/AppT.hs
@ -25,7 +25,7 @@ import UnliftIO
 import Prelude hiding (span)

 data Context = Context
-  { config :: Label "logDatabaseQueries" DebugLogDatabaseQueries,
+  { config :: T2 "logDatabaseQueries" DebugLogDatabaseQueries "prettyPrintDatabaseQueries" PrettyPrintDatabaseQueries,
    tracer :: Otel.Tracer,
    pgFormat :: PgFormatPool,
    pgConnPool :: Pool Postgres.Connection,
@ -40,7 +40,7 @@ newtype AppException = AppException Text
  deriving anyclass (Exception)

 instance Show AppException where
-  showsPrec _ (AppException t) = ("AppException: "++) . (textToString t++)
+  showsPrec _ (AppException t) = ("AppException: " ++) . (textToString t ++)

 -- *  Logging & Opentelemetry

@ -147,15 +147,18 @@ recordException span dat = liftIO $ do
 -- * Postgres

 instance (MonadThrow m, MonadUnliftIO m) => MonadPostgres (AppT m) where
-  execute = executeImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
-  executeMany = executeManyImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
-  executeManyReturningWith = executeManyReturningWithImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
-  queryWith = queryWithImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
+  execute = executeImpl (AppT ask) dbConfig
+  executeMany = executeManyImpl (AppT ask) dbConfig
+  executeManyReturningWith = executeManyReturningWithImpl (AppT ask) dbConfig
+  queryWith = queryWithImpl (AppT ask) dbConfig
  queryWith_ = queryWithImpl_ (AppT ask)

-  foldRowsWithAcc = foldRowsWithAccImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
+  foldRowsWithAcc = foldRowsWithAccImpl (AppT ask) dbConfig
  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 (Transaction transaction) = do
  pool <- AppT ask <&> (.pgConnPool)
--- a/users/Profpatsch/whatcd-resolver/src/Redacted.hs
+++ b/users/Profpatsch/whatcd-resolver/src/Redacted.hs
@ -12,7 +12,6 @@ import Data.Aeson.KeyMap qualified as KeyMap
 import Data.Error.Tree
 import Data.List qualified as List
 import Database.PostgreSQL.Simple (Binary (Binary), Only (..))
-import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Database.PostgreSQL.Simple.Types (PGArray (PGArray))
 import FieldParser qualified as Field
 import Http qualified
--- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
+++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
@ -18,7 +18,6 @@ import Data.Map.Strict qualified as Map
 import Data.Pool qualified as Pool
 import Data.Text qualified as Text
 import Database.PostgreSQL.Simple qualified as Postgres
-import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Database.PostgreSQL.Simple.Types (PGArray (PGArray))
 import Database.Postgres.Temp qualified as TmpPg
 import FieldParser (FieldParser, FieldParser' (..))
@ -778,7 +777,14 @@ runAppWith :: AppT IO a -> IO (Either TmpPg.StartError a)
 runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do
  tool <- readTools (label @"toolsEnvVar" "WHATCD_RESOLVER_TOOLS") (readTool "pg_format")
  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 <-
    Pool.newPool $
      Pool.defaultPoolConfig