From 0ec5512342300227f37a8d97e64bbf903ac0a28c Mon Sep 17 00:00:00 2001 From: eswar2001 Date: Mon, 16 Feb 2026 16:16:24 +0530 Subject: [PATCH 1/4] build fixes --- .../Database/Beam/Postgres/Connection.hs | 67 +++++++++++-------- .../Database/Beam/Postgres/Migrate.hs | 2 +- 2 files changed, 40 insertions(+), 29 deletions(-) diff --git a/beam-postgres/Database/Beam/Postgres/Connection.hs b/beam-postgres/Database/Beam/Postgres/Connection.hs index 29ed354e5..9753b960d 100644 --- a/beam-postgres/Database/Beam/Postgres/Connection.hs +++ b/beam-postgres/Database/Beam/Postgres/Connection.hs @@ -77,6 +77,25 @@ import System.Clock import Network.URI (uriToString) +import GHC.Stats (getRTSStats, RTSStats(..)) +import Data.Time.Clock.System (getSystemTime, systemToTAITime) +import Data.Time (diffTimeToPicoseconds) +import Data.Time.Clock.TAI (diffAbsoluteTime) + +-- | Track execution time and GC stats, then call callback +withTickTock :: (Text -> Text -> Text -> IO ()) -> Text -> IO a -> IO a +withTickTock callback tag action = do + t1 <- getSystemTime + rtsTick <- getRTSStats + result <- action + rtsTock <- getRTSStats + t2 <- getSystemTime + let execTime = diffTimeToPicoseconds $ diffAbsoluteTime (systemToTAITime t2) (systemToTAITime t1) + latency = execTime `div` 10 ^ (9 :: Int) + gcTime = (gc_elapsed_ns rtsTock) - (gc_elapsed_ns rtsTick) + callback (T.pack $ show latency) (T.pack $ show gcTime) tag + pure result + data PgStream a = PgStreamDone (Either BeamRowReadError a) | PgStreamContinue (Maybe PgI.Row -> IO (PgStream a)) @@ -182,8 +201,8 @@ runPgRowReader conn rowIdx res fields (FromBackendRowM readRow) = finish x _ _ _ = pure (Right x) -withPgDebug :: (Text -> IO ()) -> Pg.Connection -> Pg a -> IO (Either BeamRowReadError a) -withPgDebug dbg conn (Pg action) = +withPgDebug :: (Text -> IO ()) -> (Text -> Text -> Text -> IO ()) -> Pg.Connection -> Pg a -> IO (Either BeamRowReadError a) +withPgDebug dbg tickTock conn (Pg action) = let finish x = pure (Right x) step (PgLiftIO io next) = io >>= next step (PgLiftWithHandle withConn next) = withConn conn >>= next @@ -194,45 +213,37 @@ withPgDebug dbg conn (Pg action) = do query <- pgRenderSyntax conn syntax let Pg process = mkProcess (Pg (liftF (PgFetchNext id))) action' <- runF process finishProcess stepProcess Nothing - (res, extime) <- + res <- case action' of - PgStreamDone (Right x) -> do - start <- getTime Monotonic - Pg.execute_ conn (Pg.Query query) - end <- getTime Monotonic - (, Just (end - start)) <$> next x - PgStreamDone (Left err) -> pure (Left err, Nothing) + PgStreamDone (Right x) -> + withTickTock tickTock "EXECUTE" $ do + Pg.execute_ conn (Pg.Query query) + next x + PgStreamDone (Left err) -> pure (Left err) PgStreamContinue nextStream -> - let finishUp (PgStreamDone (Right x)) = (, Nothing) <$> next x - finishUp (PgStreamDone (Left err)) = pure (Left err, Nothing) + let finishUp (PgStreamDone (Right x)) = next x + finishUp (PgStreamDone (Left err)) = pure (Left err) finishUp (PgStreamContinue next') = next' Nothing >>= finishUp columnCount = fromIntegral $ valuesNeeded (Proxy @Postgres) (Proxy @x) - in do resp <- Pg.queryWith_ (Pg.RP (put columnCount >> ask)) conn (Pg.Query query) + in withTickTock tickTock "DECODE" $ do + resp <- withTickTock tickTock "EXECUTE" $ Pg.queryWith_ (Pg.RP (put columnCount >> ask)) conn (Pg.Query query) foldM runConsumer (PgStreamContinue nextStream) resp >>= finishUp - dbg (decodeUtf8 query <> " Executed in: " <> T.pack (show extime) <> " seconds ") >> return res + pure res step (PgRunReturning (PgCommandSyntax PgCommandTypeDataUpdateReturning syntax) mkProcess next) = do query <- pgRenderSyntax conn syntax - start <- getTime Monotonic - res <- Pg.exec conn query - end <- getTime Monotonic - let extime = end - start - dbg (decodeUtf8 query <> " Executed in: " <> T.pack (show extime) <> " seconds ") + res <- withTickTock tickTock "EXECUTE" $ Pg.exec conn query sts <- Pg.resultStatus res case sts of Pg.TuplesOk -> do let Pg process = mkProcess (Pg (liftF (PgFetchNext id))) - runF process (\x _ -> Pg.unsafeFreeResult res >> next x) (stepReturningList res) 0 + withTickTock tickTock "DECODE" $ runF process (\x _ -> Pg.unsafeFreeResult res >> next x) (stepReturningList res) 0 _ -> Pg.throwResultError "No tuples returned to Postgres update/insert returning" res sts step (PgRunReturning (PgCommandSyntax _ syntax) mkProcess next) = do query <- pgRenderSyntax conn syntax - start <- getTime Monotonic - _ <- Pg.execute_ conn (Pg.Query query) - end <- getTime Monotonic - let extime = end - start - dbg (decodeUtf8 query <> " Executed in: " <> T.pack (show extime) <> " seconds ") + withTickTock tickTock "EXECUTE" $ Pg.execute_ conn (Pg.Query query) let Pg process = mkProcess (Pg (liftF (PgFetchNext id))) runF process next stepReturningNone @@ -319,12 +330,12 @@ instance MonadIO Pg where liftIOWithHandle :: (Pg.Connection -> IO a) -> Pg a liftIOWithHandle f = liftF (PgLiftWithHandle f id) -runBeamPostgresDebug :: (Text -> IO ()) -> Pg.Connection -> Pg a -> IO a -runBeamPostgresDebug dbg conn action = - withPgDebug dbg conn action >>= either throwIO pure +runBeamPostgresDebug :: (Text -> IO ()) -> (Text -> Text -> Text -> IO ()) -> Pg.Connection -> Pg a -> IO a +runBeamPostgresDebug dbg tickTock conn action = + withPgDebug dbg tickTock conn action >>= either throwIO pure runBeamPostgres :: Pg.Connection -> Pg a -> IO a -runBeamPostgres = runBeamPostgresDebug (\_ -> pure ()) +runBeamPostgres = runBeamPostgresDebug (\_ -> pure ()) (\_ _ _ -> pure ()) instance MonadBeam Postgres Pg where runReturningMany cmd consume = diff --git a/beam-postgres/Database/Beam/Postgres/Migrate.hs b/beam-postgres/Database/Beam/Postgres/Migrate.hs index e23b20659..1760d56cf 100644 --- a/beam-postgres/Database/Beam/Postgres/Migrate.hs +++ b/beam-postgres/Database/Beam/Postgres/Migrate.hs @@ -99,7 +99,7 @@ migrationBackend = Tool.BeamMigrationBackend pgCustomEnumActionProvider) (\options action -> bracket (Pg.connectPostgreSQL (fromString options)) Pg.close $ \conn -> - left show <$> withPgDebug (\_ -> pure ()) conn action) + left show <$> withPgDebug (\_ -> pure ()) (\_ _ _ -> pure ()) conn action) -- | 'BeamDeserializers' for postgres-specific types: -- From b9e54e4c0c21da497d0a102fd8f13d857b16e93a Mon Sep 17 00:00:00 2001 From: eswar2001 Date: Mon, 16 Feb 2026 19:06:36 +0530 Subject: [PATCH 2/4] added beam query render time also --- .../Database/Beam/Postgres/Connection.hs | 45 ++++++++++++------- .../Database/Beam/Postgres/Migrate.hs | 2 +- 2 files changed, 31 insertions(+), 16 deletions(-) diff --git a/beam-postgres/Database/Beam/Postgres/Connection.hs b/beam-postgres/Database/Beam/Postgres/Connection.hs index 9753b960d..3aba30364 100644 --- a/beam-postgres/Database/Beam/Postgres/Connection.hs +++ b/beam-postgres/Database/Beam/Postgres/Connection.hs @@ -61,6 +61,7 @@ import qualified Control.Monad.Fail as Fail import Data.ByteString (ByteString) import Data.ByteString.Builder (toLazyByteString, byteString) import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BLC import Data.Maybe (listToMaybe, fromMaybe) import Data.Proxy import Data.String @@ -83,8 +84,8 @@ import Data.Time (diffTimeToPicoseconds) import Data.Time.Clock.TAI (diffAbsoluteTime) -- | Track execution time and GC stats, then call callback -withTickTock :: (Text -> Text -> Text -> IO ()) -> Text -> IO a -> IO a -withTickTock callback tag action = do +withTickTock :: (Text -> Text -> Text -> ByteString -> IO ()) -> Text -> ByteString -> IO a -> IO a +withTickTock callback tag query action = do t1 <- getSystemTime rtsTick <- getRTSStats result <- action @@ -93,7 +94,21 @@ withTickTock callback tag action = do let execTime = diffTimeToPicoseconds $ diffAbsoluteTime (systemToTAITime t2) (systemToTAITime t1) latency = execTime `div` 10 ^ (9 :: Int) gcTime = (gc_elapsed_ns rtsTock) - (gc_elapsed_ns rtsTick) - callback (T.pack $ show latency) (T.pack $ show gcTime) tag + callback (T.pack $ show latency <> " ms") (T.pack $ show gcTime <> " ns") tag query + pure result + +-- | Track execution time and GC stats, then call callback +withTickTock' :: (Text -> Text -> Text -> ByteString -> IO ()) -> Text -> IO ByteString -> IO a +withTickTock' callback tag action = do + t1 <- getSystemTime + rtsTick <- getRTSStats + result <- action + rtsTock <- getRTSStats + t2 <- getSystemTime + let execTime = diffTimeToPicoseconds $ diffAbsoluteTime (systemToTAITime t2) (systemToTAITime t1) + latency = execTime `div` 10 ^ (9 :: Int) + gcTime = (gc_elapsed_ns rtsTock) - (gc_elapsed_ns rtsTick) + callback (T.pack $ show latency) (T.pack $ show gcTime) tag result pure result data PgStream a = PgStreamDone (Either BeamRowReadError a) @@ -201,7 +216,7 @@ runPgRowReader conn rowIdx res fields (FromBackendRowM readRow) = finish x _ _ _ = pure (Right x) -withPgDebug :: (Text -> IO ()) -> (Text -> Text -> Text -> IO ()) -> Pg.Connection -> Pg a -> IO (Either BeamRowReadError a) +withPgDebug :: (Text -> IO ()) -> (Text -> Text -> Text -> ByteString -> IO ()) -> Pg.Connection -> Pg a -> IO (Either BeamRowReadError a) withPgDebug dbg tickTock conn (Pg action) = let finish x = pure (Right x) step (PgLiftIO io next) = io >>= next @@ -210,13 +225,13 @@ withPgDebug dbg tickTock conn (Pg action) = step (PgRunReturning (PgCommandSyntax PgCommandTypeQuery syntax) (mkProcess :: Pg (Maybe x) -> Pg a') next) = - do query <- pgRenderSyntax conn syntax + do query <- withTickTock' tickTock "ORM_QUERY" $ pgRenderSyntax conn syntax let Pg process = mkProcess (Pg (liftF (PgFetchNext id))) action' <- runF process finishProcess stepProcess Nothing res <- case action' of PgStreamDone (Right x) -> - withTickTock tickTock "EXECUTE" $ do + withTickTock tickTock "EXECUTE" query $ do Pg.execute_ conn (Pg.Query query) next x PgStreamDone (Left err) -> pure (Left err) @@ -226,24 +241,24 @@ withPgDebug dbg tickTock conn (Pg action) = finishUp (PgStreamContinue next') = next' Nothing >>= finishUp columnCount = fromIntegral $ valuesNeeded (Proxy @Postgres) (Proxy @x) - in withTickTock tickTock "DECODE" $ do - resp <- withTickTock tickTock "EXECUTE" $ Pg.queryWith_ (Pg.RP (put columnCount >> ask)) conn (Pg.Query query) - foldM runConsumer (PgStreamContinue nextStream) resp >>= finishUp + in do + resp <- withTickTock tickTock "EXECUTE" query $ Pg.queryWith_ (Pg.RP (put columnCount >> ask)) conn (Pg.Query query) + withTickTock tickTock "DECODE" (query <> " rows returned " <> (BLC.pack $ show $ length resp)) $ foldM runConsumer (PgStreamContinue nextStream) resp >>= finishUp pure res step (PgRunReturning (PgCommandSyntax PgCommandTypeDataUpdateReturning syntax) mkProcess next) = - do query <- pgRenderSyntax conn syntax + do query <- withTickTock' tickTock "ORM_QUERY" $ pgRenderSyntax conn syntax - res <- withTickTock tickTock "EXECUTE" $ Pg.exec conn query + res <- withTickTock tickTock "EXECUTE" query $ Pg.exec conn query sts <- Pg.resultStatus res case sts of Pg.TuplesOk -> do let Pg process = mkProcess (Pg (liftF (PgFetchNext id))) - withTickTock tickTock "DECODE" $ runF process (\x _ -> Pg.unsafeFreeResult res >> next x) (stepReturningList res) 0 + withTickTock tickTock "DECODE" query $ runF process (\x _ -> Pg.unsafeFreeResult res >> next x) (stepReturningList res) 0 _ -> Pg.throwResultError "No tuples returned to Postgres update/insert returning" res sts step (PgRunReturning (PgCommandSyntax _ syntax) mkProcess next) = - do query <- pgRenderSyntax conn syntax - withTickTock tickTock "EXECUTE" $ Pg.execute_ conn (Pg.Query query) + do query <- withTickTock' tickTock "ORM_QUERY" $ pgRenderSyntax conn syntax + withTickTock tickTock "EXECUTE" query $ Pg.execute_ conn (Pg.Query query) let Pg process = mkProcess (Pg (liftF (PgFetchNext id))) runF process next stepReturningNone @@ -330,7 +345,7 @@ instance MonadIO Pg where liftIOWithHandle :: (Pg.Connection -> IO a) -> Pg a liftIOWithHandle f = liftF (PgLiftWithHandle f id) -runBeamPostgresDebug :: (Text -> IO ()) -> (Text -> Text -> Text -> IO ()) -> Pg.Connection -> Pg a -> IO a +runBeamPostgresDebug :: (Text -> IO ()) -> (Text -> Text -> Text -> ByteString -> IO ()) -> Pg.Connection -> Pg a -> IO a runBeamPostgresDebug dbg tickTock conn action = withPgDebug dbg tickTock conn action >>= either throwIO pure diff --git a/beam-postgres/Database/Beam/Postgres/Migrate.hs b/beam-postgres/Database/Beam/Postgres/Migrate.hs index 1760d56cf..f0fe2a3bb 100644 --- a/beam-postgres/Database/Beam/Postgres/Migrate.hs +++ b/beam-postgres/Database/Beam/Postgres/Migrate.hs @@ -99,7 +99,7 @@ migrationBackend = Tool.BeamMigrationBackend pgCustomEnumActionProvider) (\options action -> bracket (Pg.connectPostgreSQL (fromString options)) Pg.close $ \conn -> - left show <$> withPgDebug (\_ -> pure ()) (\_ _ _ -> pure ()) conn action) + left show <$> withPgDebug (\_ -> pure ()) (\_ _ _ _ -> pure ()) conn action) -- | 'BeamDeserializers' for postgres-specific types: -- From 85d4033d70bf07cacb09b7944f01bf6a6a122964 Mon Sep 17 00:00:00 2001 From: eswar2001 Date: Mon, 16 Feb 2026 19:10:17 +0530 Subject: [PATCH 3/4] build fixes --- beam-postgres/Database/Beam/Postgres/Connection.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/beam-postgres/Database/Beam/Postgres/Connection.hs b/beam-postgres/Database/Beam/Postgres/Connection.hs index 3aba30364..3892df9d6 100644 --- a/beam-postgres/Database/Beam/Postgres/Connection.hs +++ b/beam-postgres/Database/Beam/Postgres/Connection.hs @@ -350,7 +350,7 @@ runBeamPostgresDebug dbg tickTock conn action = withPgDebug dbg tickTock conn action >>= either throwIO pure runBeamPostgres :: Pg.Connection -> Pg a -> IO a -runBeamPostgres = runBeamPostgresDebug (\_ -> pure ()) (\_ _ _ -> pure ()) +runBeamPostgres = runBeamPostgresDebug (\_ -> pure ()) (\_ _ _ _ -> pure ()) instance MonadBeam Postgres Pg where runReturningMany cmd consume = From 506874a1a3b6a124e9454751ae5c52ed9daa522c Mon Sep 17 00:00:00 2001 From: eswar2001 Date: Mon, 16 Feb 2026 19:13:00 +0530 Subject: [PATCH 4/4] build fixes --- beam-postgres/Database/Beam/Postgres/Connection.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/beam-postgres/Database/Beam/Postgres/Connection.hs b/beam-postgres/Database/Beam/Postgres/Connection.hs index 3892df9d6..c2deb8c9a 100644 --- a/beam-postgres/Database/Beam/Postgres/Connection.hs +++ b/beam-postgres/Database/Beam/Postgres/Connection.hs @@ -98,7 +98,7 @@ withTickTock callback tag query action = do pure result -- | Track execution time and GC stats, then call callback -withTickTock' :: (Text -> Text -> Text -> ByteString -> IO ()) -> Text -> IO ByteString -> IO a +withTickTock' :: (Text -> Text -> Text -> ByteString -> IO ()) -> Text -> IO ByteString -> IO ByteString withTickTock' callback tag action = do t1 <- getSystemTime rtsTick <- getRTSStats