From 69f031b47d9690ad29c78d09fc4268aef9416a5f Mon Sep 17 00:00:00 2001 From: adiR28 Date: Tue, 20 Feb 2024 16:47:23 +0530 Subject: [PATCH 1/6] fix : fetch raw query incase of SqlError also --- beam-postgres/Database/Beam/Postgres/Connection.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/beam-postgres/Database/Beam/Postgres/Connection.hs b/beam-postgres/Database/Beam/Postgres/Connection.hs index 96fa47bdb..5250c65de 100644 --- a/beam-postgres/Database/Beam/Postgres/Connection.hs +++ b/beam-postgres/Database/Beam/Postgres/Connection.hs @@ -192,6 +192,7 @@ withPgDebug dbg conn (Pg action) = (mkProcess :: Pg (Maybe x) -> Pg a') next) = do query <- pgRenderSyntax conn syntax + dbg (decodeUtf8 query) let Pg process = mkProcess (Pg (liftF (PgFetchNext id))) action' <- runF process finishProcess stepProcess Nothing (res, extime) <- @@ -214,17 +215,17 @@ withPgDebug dbg conn (Pg action) = columnCount = fromIntegral $ valuesNeeded (Proxy @Postgres) (Proxy @x) resp <- Pg.queryWith_ (Pg.RP (put columnCount >> ask)) conn (Pg.Query query) foldM runConsumer (PgStreamContinue nextStream) resp >>= finishUp - when (extime /= Nothing) $ dbg (decodeUtf8 query <> " Executed in: " <> T.pack (show (((sec (fromJust extime)) * 1000) + ((nsec (fromJust extime)) `div` 1000000)) <> " ms ")) - when (extime == Nothing) $ dbg (decodeUtf8 query) + -- when (extime /= Nothing) $ dbg (decodeUtf8 query <> " Executed in: " <> T.pack (show (((sec (fromJust extime)) * 1000) + ((nsec (fromJust extime)) `div` 1000000)) <> " ms ")) + -- when (extime == Nothing) $ dbg (decodeUtf8 query) return res step (PgRunReturning (PgCommandSyntax PgCommandTypeDataUpdateReturning syntax) mkProcess next) = do query <- pgRenderSyntax conn syntax - + dbg (decodeUtf8 query) start <- getTime Monotonic res <- Pg.exec conn query end <- getTime Monotonic let extime = end - start - dbg (decodeUtf8 query <> " Executed in: " <> T.pack (show (((sec extime) * 1000) + ((nsec extime) `div` 1000000)) <> " ms ")) + -- dbg (decodeUtf8 query <> " Executed in: " <> T.pack (show (((sec extime) * 1000) + ((nsec extime) `div` 1000000)) <> " ms ")) sts <- Pg.resultStatus res case sts of Pg.TuplesOk -> do @@ -234,11 +235,12 @@ withPgDebug dbg conn (Pg action) = res sts step (PgRunReturning (PgCommandSyntax _ syntax) mkProcess next) = do query <- pgRenderSyntax conn syntax + dbg (decodeUtf8 query) start <- getTime Monotonic _ <- Pg.execute_ conn (Pg.Query query) end <- getTime Monotonic let extime = end - start - dbg (decodeUtf8 query <> " Executed in: " <> T.pack (show (((sec extime) * 1000) + ((nsec extime) `div` 1000000)) <> " ms ")) + -- dbg (decodeUtf8 query <> " Executed in: " <> T.pack (show (((sec extime) * 1000) + ((nsec extime) `div` 1000000)) <> " ms ")) let Pg process = mkProcess (Pg (liftF (PgFetchNext id))) runF process next stepReturningNone From 516303ecfa2c183effa8c55bb6a272a9e28cfccd Mon Sep 17 00:00:00 2001 From: adiR28 Date: Tue, 7 May 2024 11:47:30 +0530 Subject: [PATCH 2/6] fix : export Pg monad for displaySyntax function --- beam-postgres/Database/Beam/Postgres.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/beam-postgres/Database/Beam/Postgres.hs b/beam-postgres/Database/Beam/Postgres.hs index 8dd4aa5c3..cf76170a0 100644 --- a/beam-postgres/Database/Beam/Postgres.hs +++ b/beam-postgres/Database/Beam/Postgres.hs @@ -19,12 +19,13 @@ module Database.Beam.Postgres ( -- * Beam Postgres backend - Postgres(..), Pg, liftIOWithHandle + Postgres(..), Pg(..), liftIOWithHandle -- ** Postgres syntax , PgCommandSyntax, PgSyntax , PgSelectSyntax, PgInsertSyntax , PgUpdateSyntax, PgDeleteSyntax + , PgF(..) -- * Beam URI support , postgresUriSyntax From 13077ed0f013da956c9c683074cb72c5aeeffbe8 Mon Sep 17 00:00:00 2001 From: adiR28 Date: Wed, 7 Aug 2024 17:34:13 +0530 Subject: [PATCH 3/6] UPI-3426 fix : added exception handling --- .../Database/Beam/Postgres/Connection.hs | 61 ++++++++++++------- 1 file changed, 38 insertions(+), 23 deletions(-) diff --git a/beam-postgres/Database/Beam/Postgres/Connection.hs b/beam-postgres/Database/Beam/Postgres/Connection.hs index 5250c65de..df8aa3595 100644 --- a/beam-postgres/Database/Beam/Postgres/Connection.hs +++ b/beam-postgres/Database/Beam/Postgres/Connection.hs @@ -76,6 +76,7 @@ import Foreign.C.Types import System.Clock import Network.URI (uriToString) +import Control.Exception (try) data PgStream a = PgStreamDone (Either BeamRowReadError a) | PgStreamContinue (Maybe PgI.Row -> IO (PgStream a)) @@ -199,9 +200,14 @@ withPgDebug dbg conn (Pg action) = case action' of PgStreamDone (Right x) -> do start <- getTime Monotonic - Pg.execute_ conn (Pg.Query query) - end <- getTime Monotonic - (, Just (end - start)) <$> next x + (respWithException ::Either SomeException a) <- try $ Pg.execute_ conn (Pg.Query query) + case respWithException of + Left err -> do + dbg (decodeUtf8 query) + return (Left $ BeamRowReadError Nothing $ ColumnErrorInternal (show err ) , Nothing) + Right _ -> do + end <- getTime Monotonic + (, Just (end - start)) <$> next x PgStreamDone (Left err) -> pure (Left err, Nothing) PgStreamContinue nextStream -> do start <- getTime Monotonic @@ -215,34 +221,43 @@ withPgDebug dbg conn (Pg action) = columnCount = fromIntegral $ valuesNeeded (Proxy @Postgres) (Proxy @x) resp <- Pg.queryWith_ (Pg.RP (put columnCount >> ask)) conn (Pg.Query query) foldM runConsumer (PgStreamContinue nextStream) resp >>= finishUp - -- when (extime /= Nothing) $ dbg (decodeUtf8 query <> " Executed in: " <> T.pack (show (((sec (fromJust extime)) * 1000) + ((nsec (fromJust extime)) `div` 1000000)) <> " ms ")) - -- when (extime == Nothing) $ dbg (decodeUtf8 query) + when (extime /= Nothing) $ dbg (decodeUtf8 query <> " Executed in: " <> T.pack (show (((sec (fromJust extime)) * 1000) + ((nsec (fromJust extime)) `div` 1000000)) <> " ms ")) + when (extime == Nothing) $ dbg (decodeUtf8 query) return res step (PgRunReturning (PgCommandSyntax PgCommandTypeDataUpdateReturning syntax) mkProcess next) = do query <- pgRenderSyntax conn syntax - dbg (decodeUtf8 query) start <- getTime Monotonic - res <- Pg.exec conn query - end <- getTime Monotonic - let extime = end - start - -- dbg (decodeUtf8 query <> " Executed in: " <> T.pack (show (((sec extime) * 1000) + ((nsec extime) `div` 1000000)) <> " ms ")) - 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 - _ -> Pg.throwResultError "No tuples returned to Postgres update/insert returning" - res sts + (respWithException :: Either SomeException a) <- try $ Pg.exec conn query + case respWithException of + Left err -> do + dbg (decodeUtf8 query) + return $ Left $ BeamRowReadError Nothing $ ColumnErrorInternal (show err ) + Right res -> do + end <- getTime Monotonic + let extime = end - start + dbg (decodeUtf8 query <> " Executed in: " <> T.pack (show (((sec extime) * 1000) + ((nsec extime) `div` 1000000)) <> " ms ")) + 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 + _ -> Pg.throwResultError "No tuples returned to Postgres update/insert returning" + res sts step (PgRunReturning (PgCommandSyntax _ syntax) mkProcess next) = do query <- pgRenderSyntax conn syntax dbg (decodeUtf8 query) start <- getTime Monotonic - _ <- Pg.execute_ conn (Pg.Query query) - end <- getTime Monotonic - let extime = end - start - -- dbg (decodeUtf8 query <> " Executed in: " <> T.pack (show (((sec extime) * 1000) + ((nsec extime) `div` 1000000)) <> " ms ")) - let Pg process = mkProcess (Pg (liftF (PgFetchNext id))) - runF process next stepReturningNone + (respWithException :: Either SomeException a) <- try $ Pg.execute_ conn (Pg.Query query) + case respWithException of + Left err -> do + dbg (decodeUtf8 query) + return $ Left $ BeamRowReadError Nothing $ ColumnErrorInternal (show err ) + Right _ -> do + end <- getTime Monotonic + let extime = end - start + dbg (decodeUtf8 query <> " Executed in: " <> T.pack (show (((sec extime) * 1000) + ((nsec extime) `div` 1000000)) <> " ms ")) + let Pg process = mkProcess (Pg (liftF (PgFetchNext id))) + runF process next stepReturningNone stepReturningNone :: forall a. PgF (IO (Either BeamRowReadError a)) -> IO (Either BeamRowReadError a) stepReturningNone (PgLiftIO action' next) = action' >>= next From 59de6b2bb5dbf4483dbe675695246fa0a16217e9 Mon Sep 17 00:00:00 2001 From: adiR28 Date: Wed, 7 Aug 2024 17:35:37 +0530 Subject: [PATCH 4/6] UPI-3426 fix : removed redundant code --- beam-postgres/Database/Beam/Postgres/Connection.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/beam-postgres/Database/Beam/Postgres/Connection.hs b/beam-postgres/Database/Beam/Postgres/Connection.hs index df8aa3595..61abdca5d 100644 --- a/beam-postgres/Database/Beam/Postgres/Connection.hs +++ b/beam-postgres/Database/Beam/Postgres/Connection.hs @@ -193,7 +193,6 @@ withPgDebug dbg conn (Pg action) = (mkProcess :: Pg (Maybe x) -> Pg a') next) = do query <- pgRenderSyntax conn syntax - dbg (decodeUtf8 query) let Pg process = mkProcess (Pg (liftF (PgFetchNext id))) action' <- runF process finishProcess stepProcess Nothing (res, extime) <- @@ -245,7 +244,6 @@ withPgDebug dbg conn (Pg action) = res sts step (PgRunReturning (PgCommandSyntax _ syntax) mkProcess next) = do query <- pgRenderSyntax conn syntax - dbg (decodeUtf8 query) start <- getTime Monotonic (respWithException :: Either SomeException a) <- try $ Pg.execute_ conn (Pg.Query query) case respWithException of From f7e0ec0fe3648dce95863f197e85d23a1dc1819f Mon Sep 17 00:00:00 2001 From: Atharva Bhadale Date: Tue, 2 Sep 2025 17:06:08 +0530 Subject: [PATCH 5/6] UPI-5042 FromJSON and ToJSON instances for PgJSON Signed-off-by: Atharva Bhadale --- .../Database/Beam/Postgres/PgSpecific.hs | 15 +++++++++++++++ beam-postgres/beam-postgres.cabal | 3 ++- 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/beam-postgres/Database/Beam/Postgres/PgSpecific.hs b/beam-postgres/Database/Beam/Postgres/PgSpecific.hs index a17e4f2a9..68621698b 100644 --- a/beam-postgres/Database/Beam/Postgres/PgSpecific.hs +++ b/beam-postgres/Database/Beam/Postgres/PgSpecific.hs @@ -137,6 +137,7 @@ import Data.Hashable import qualified Data.List.NonEmpty as NE import Data.Proxy import Data.Scientific (Scientific, formatScientific, FPFormat(Fixed)) +import qualified Data.Serialize as DS import Data.String import qualified Data.Text as T import Data.Time (LocalTime) @@ -720,6 +721,20 @@ instance ToJSON a => HasSqlValueSyntax PgValueSyntax (PgJSON a) where PgValueSyntax $ emit "'" <> escapeString (BL.toStrict (encode a)) <> emit "'::json" +instance (ToJSON a) => ToJSON (PgJSON a) where + toJSON (PgJSON x) = toJSON x + +instance (FromJSON a) => FromJSON (PgJSON a) where + parseJSON v = PgJSON <$> parseJSON v + +instance (ToJSON a, FromJSON a) => DS.Serialize (PgJSON a) where + put (PgJSON x) = DS.put (BL.toStrict (Data.Aeson.encode x)) + get = do + bs <- DS.get @BL.ByteString + case Data.Aeson.eitherDecode bs of + Left err -> fail ("Failed to deserialize PgJSON: " ++ err) + Right x -> pure (PgJSON x) + -- | The Postgres @JSONB@ type, which stores JSON-encoded data in a -- postgres-specific binary format. Like 'PgJSON', the type parameter indicates -- the Haskell type which the JSON encodes. diff --git a/beam-postgres/beam-postgres.cabal b/beam-postgres/beam-postgres.cabal index 12a58a9f0..1f3423985 100644 --- a/beam-postgres/beam-postgres.cabal +++ b/beam-postgres/beam-postgres.cabal @@ -57,7 +57,8 @@ library tagged >=0.8 && <0.9, haskell-src-exts >=1.18 && <1.22, - clock + clock, + cereal default-language: Haskell2010 default-extensions: ScopedTypeVariables, OverloadedStrings, MultiParamTypeClasses, RankNTypes, FlexibleInstances, DeriveDataTypeable, DeriveGeneric, StandaloneDeriving, TypeFamilies, GADTs, OverloadedStrings, From 9c2005c12c9b9f9c711c87f23eaf816b13fc9c21 Mon Sep 17 00:00:00 2001 From: Atharva Bhadale Date: Tue, 2 Sep 2025 17:37:46 +0530 Subject: [PATCH 6/6] UPI-5042 removed serialize instance Signed-off-by: Atharva Bhadale --- beam-postgres/Database/Beam/Postgres/PgSpecific.hs | 9 --------- beam-postgres/beam-postgres.cabal | 3 +-- 2 files changed, 1 insertion(+), 11 deletions(-) diff --git a/beam-postgres/Database/Beam/Postgres/PgSpecific.hs b/beam-postgres/Database/Beam/Postgres/PgSpecific.hs index 68621698b..0a20c8593 100644 --- a/beam-postgres/Database/Beam/Postgres/PgSpecific.hs +++ b/beam-postgres/Database/Beam/Postgres/PgSpecific.hs @@ -137,7 +137,6 @@ import Data.Hashable import qualified Data.List.NonEmpty as NE import Data.Proxy import Data.Scientific (Scientific, formatScientific, FPFormat(Fixed)) -import qualified Data.Serialize as DS import Data.String import qualified Data.Text as T import Data.Time (LocalTime) @@ -727,14 +726,6 @@ instance (ToJSON a) => ToJSON (PgJSON a) where instance (FromJSON a) => FromJSON (PgJSON a) where parseJSON v = PgJSON <$> parseJSON v -instance (ToJSON a, FromJSON a) => DS.Serialize (PgJSON a) where - put (PgJSON x) = DS.put (BL.toStrict (Data.Aeson.encode x)) - get = do - bs <- DS.get @BL.ByteString - case Data.Aeson.eitherDecode bs of - Left err -> fail ("Failed to deserialize PgJSON: " ++ err) - Right x -> pure (PgJSON x) - -- | The Postgres @JSONB@ type, which stores JSON-encoded data in a -- postgres-specific binary format. Like 'PgJSON', the type parameter indicates -- the Haskell type which the JSON encodes. diff --git a/beam-postgres/beam-postgres.cabal b/beam-postgres/beam-postgres.cabal index 1f3423985..12a58a9f0 100644 --- a/beam-postgres/beam-postgres.cabal +++ b/beam-postgres/beam-postgres.cabal @@ -57,8 +57,7 @@ library tagged >=0.8 && <0.9, haskell-src-exts >=1.18 && <1.22, - clock, - cereal + clock default-language: Haskell2010 default-extensions: ScopedTypeVariables, OverloadedStrings, MultiParamTypeClasses, RankNTypes, FlexibleInstances, DeriveDataTypeable, DeriveGeneric, StandaloneDeriving, TypeFamilies, GADTs, OverloadedStrings,