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 diff --git a/beam-postgres/Database/Beam/Postgres/Connection.hs b/beam-postgres/Database/Beam/Postgres/Connection.hs index 96fa47bdb..61abdca5d 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)) @@ -198,9 +199,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 @@ -219,28 +225,37 @@ withPgDebug dbg conn (Pg action) = return 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 (((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 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 diff --git a/beam-postgres/Database/Beam/Postgres/PgSpecific.hs b/beam-postgres/Database/Beam/Postgres/PgSpecific.hs index a17e4f2a9..0a20c8593 100644 --- a/beam-postgres/Database/Beam/Postgres/PgSpecific.hs +++ b/beam-postgres/Database/Beam/Postgres/PgSpecific.hs @@ -720,6 +720,12 @@ 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 + -- | 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.