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>

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
+    (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
-    traceQueryIfEnabled tools span logDatabaseQueries qry (HasSingleParam params)
+    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
+    (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
-    traceQueryIfEnabled @() tools span logDatabaseQueries qry HasNoParams
+    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
+    (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
-    traceQueryIfEnabled tools span logDatabaseQueries qry (HasMultiParams params)
+    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
+    (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
-    traceQueryIfEnabled tools span logDatabaseQueries qry (HasMultiParams params)
+    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
+    (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
-    traceQueryIfEnabled tools span logDatabaseQueries qry (HasSingleParam params)
+    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
+    (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
-    traceQueryIfEnabled tools span logDatabaseQueries qry (HasSingleParam params)
+    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,12 +851,15 @@ 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
+  let formattedQuery = case prettyQuery of
+        DontPrettyPrintDatabaseQueries -> pure qry.fromQuery
+        PrettyPrintDatabaseQueries -> do
           withEvent
             span
             "Query Format start"
@@ -856,7 +873,7 @@ traceQueryIfEnabled tools span logDatabaseQueries qry params = do
         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)

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))
+  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)
 
-  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)

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

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