From d17865265a6b99543425937614c9cdaf5a8de029 Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Tue, 15 Jul 2025 22:33:19 +0200 Subject: [PATCH] Add Connection type --- lib/Database/PostgreSQL/Opium.hs | 42 +++++---- lib/Database/PostgreSQL/Opium/Connection.hs | 39 ++++++++ lib/Database/PostgreSQL/Opium/Error.hs | 1 + opium.cabal | 4 +- .../PostgreSQL/Opium/FromFieldSpec.hs | 5 +- test/Database/PostgreSQL/Opium/FromRowSpec.hs | 92 +++++++++++++++++++ test/Database/PostgreSQL/OpiumSpec.hs | 85 ++--------------- test/SpecHook.hs | 29 +++--- 8 files changed, 180 insertions(+), 117 deletions(-) create mode 100644 lib/Database/PostgreSQL/Opium/Connection.hs create mode 100644 test/Database/PostgreSQL/Opium/FromRowSpec.hs diff --git a/lib/Database/PostgreSQL/Opium.hs b/lib/Database/PostgreSQL/Opium.hs index 4e33796..b4c4244 100644 --- a/lib/Database/PostgreSQL/Opium.hs +++ b/lib/Database/PostgreSQL/Opium.hs @@ -1,16 +1,19 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module Database.PostgreSQL.Opium + -- * Connection Management + ( Connection + , connect + , close -- * Queries -- -- Functions for performing queries. @fetch@ retrieves rows, @execute@ doesn't. -- The 'Connection' parameter comes last to facilitate currying for implicitly passing in the connection, e.g. from some framework's connection pool. -- -- | TODO: Add @newtype Query = Query Text@ with @IsString@ instance to make constructing query strings at run time harder. - ( fetch + , fetch , fetch_ , execute , execute_ @@ -28,18 +31,16 @@ module Database.PostgreSQL.Opium import Control.Monad (unless, void) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Except (ExceptT (..), except, runExceptT, throwE) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE) import Data.Functor.Identity (Identity (..)) import Data.Proxy (Proxy (..)) import Data.Text (Text) -import Database.PostgreSQL.LibPQ - ( Connection - , Result - ) +import Database.PostgreSQL.LibPQ (Result) import qualified Data.Text.Encoding as Encoding import qualified Database.PostgreSQL.LibPQ as LibPQ +import Database.PostgreSQL.Opium.Connection (Connection, connect, close, withRawConnection) import Database.PostgreSQL.Opium.Error (Error (..), ErrorPosition (..)) import Database.PostgreSQL.Opium.FromField (FromField (..), RawField (..)) import Database.PostgreSQL.Opium.FromRow (FromRow (..), ColumnTable) @@ -99,13 +100,20 @@ execParams -> ExceptT Error IO Result execParams conn query params = do let queryBytes = Encoding.encodeUtf8 query - liftIO (LibPQ.execParams conn queryBytes (toParamList params) LibPQ.Binary) >>= \case - Nothing -> - except $ Left ErrorNoResult - Just result -> do - status <- liftIO $ LibPQ.resultStatus result - mbMessage <- liftIO $ LibPQ.resultErrorMessage result - case mbMessage of - Just "" -> pure result - Nothing -> pure result - Just message -> except $ Left $ ErrorInvalidResult status $ Encoding.decodeUtf8 message + -- Actually run the query while locking the connection. + mbResult <- + flip withRawConnection conn $ \mbRawConn -> do + rawConn <- mbRawConn `orThrow` ErrorConnectionClosed + liftIO $ LibPQ.execParams rawConn queryBytes (toParamList params) LibPQ.Binary + -- Check whether the result is valid or nah. + result <- mbResult `orThrow` ErrorNoResult + status <- liftIO $ LibPQ.resultStatus result + mbMessage <- liftIO $ LibPQ.resultErrorMessage result + case mbMessage of + Just "" -> pure result + Nothing -> pure result + Just message -> throwE $ ErrorInvalidResult status $ Encoding.decodeUtf8 message + + where + orThrow (Just x) _ = pure x + orThrow Nothing e = throwE e diff --git a/lib/Database/PostgreSQL/Opium/Connection.hs b/lib/Database/PostgreSQL/Opium/Connection.hs new file mode 100644 index 0000000..dc6c2c3 --- /dev/null +++ b/lib/Database/PostgreSQL/Opium/Connection.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE LambdaCase #-} + +module Database.PostgreSQL.Opium.Connection + ( Connection + , unsafeWithRawConnection + , withRawConnection + , connect + , close + ) where + +import Data.ByteString (ByteString) +import GHC.Stack (HasCallStack) + +import qualified Database.PostgreSQL.LibPQ as LibPQ + +newtype Connection = Connection LibPQ.Connection + +withRawConnection + :: (Maybe LibPQ.Connection -> m a) + -> Connection + -> m a +withRawConnection f (Connection rawConn) = f (Just rawConn) + +unsafeWithRawConnection + :: HasCallStack + => (LibPQ.Connection -> m a) + -> Connection + -> m a +unsafeWithRawConnection f = withRawConnection $ \case + Nothing -> error "raw connection is missing! perhaps the connection was already closed." + Just rawConn -> f rawConn + +connect :: ByteString -> IO Connection +connect connectionString = do + rawConn <- LibPQ.connectdb connectionString + pure $ Connection rawConn + +close :: Connection -> IO () +close (Connection rawConn) = LibPQ.finish rawConn diff --git a/lib/Database/PostgreSQL/Opium/Error.hs b/lib/Database/PostgreSQL/Opium/Error.hs index 2b6e3a8..0485b97 100644 --- a/lib/Database/PostgreSQL/Opium/Error.hs +++ b/lib/Database/PostgreSQL/Opium/Error.hs @@ -19,6 +19,7 @@ data Error | ErrorInvalidField ErrorPosition Oid ByteString String | ErrorNotExactlyOneRow | ErrorMoreThanOneRow + | ErrorConnectionClosed deriving (Eq, Show) instance Exception Error where diff --git a/opium.cabal b/opium.cabal index 9a32840..290a998 100644 --- a/opium.cabal +++ b/opium.cabal @@ -63,6 +63,7 @@ library Database.PostgreSQL.Opium, Database.PostgreSQL.Opium.FromField, Database.PostgreSQL.Opium.FromRow, + Database.PostgreSQL.Opium.Connection, Database.PostgreSQL.Opium.ToField -- Modules included in this library but not exported. @@ -117,7 +118,8 @@ test-suite opium-test other-modules: SpecHook, Database.PostgreSQL.OpiumSpec, - Database.PostgreSQL.Opium.FromFieldSpec + Database.PostgreSQL.Opium.FromFieldSpec, + Database.PostgreSQL.Opium.FromRowSpec -- Test dependencies. build-depends: diff --git a/test/Database/PostgreSQL/Opium/FromFieldSpec.hs b/test/Database/PostgreSQL/Opium/FromFieldSpec.hs index b626666..7bf673e 100644 --- a/test/Database/PostgreSQL/Opium/FromFieldSpec.hs +++ b/test/Database/PostgreSQL/Opium/FromFieldSpec.hs @@ -14,7 +14,6 @@ import Data.Time , timeOfDayToTime ) import Data.Text (Text) -import Database.PostgreSQL.LibPQ (Connection) import Database.PostgreSQL.Opium (FromRow) import GHC.Generics (Generic) import Test.Hspec (SpecWith, describe, it, shouldBe, shouldSatisfy) @@ -113,7 +112,7 @@ newtype ARawField = ARawField instance FromRow ARawField where -shouldFetch :: (Eq a, FromRow a, Show a) => Connection -> Text -> [a] -> IO () +shouldFetch :: (Eq a, FromRow a, Show a) => Opium.Connection -> Text -> [a] -> IO () shouldFetch conn query expectedRows = do actualRows <- Opium.fetch_ query conn actualRows `shouldBe` Right expectedRows @@ -121,7 +120,7 @@ shouldFetch conn query expectedRows = do (/\) :: (a -> Bool) -> (a -> Bool) -> a -> Bool p /\ q = \x -> p x && q x -spec :: SpecWith Connection +spec :: SpecWith Opium.Connection spec = do describe "FromField Int" $ do it "Decodes smallint" $ \conn -> do diff --git a/test/Database/PostgreSQL/Opium/FromRowSpec.hs b/test/Database/PostgreSQL/Opium/FromRowSpec.hs new file mode 100644 index 0000000..e9b7932 --- /dev/null +++ b/test/Database/PostgreSQL/Opium/FromRowSpec.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Database.PostgreSQL.Opium.FromRowSpec (spec) where + +import Data.ByteString (ByteString) +import Data.Proxy (Proxy (..)) +import Test.Hspec (SpecWith, aroundWith, describe, it, shouldBe) + +import qualified Database.PostgreSQL.LibPQ as LibPQ + +import Database.PostgreSQL.Opium.Connection (unsafeWithRawConnection) +import Database.PostgreSQL.OpiumSpec (ManyFields (..), MaybeTest (..), Person (..), Only (..)) + +import qualified Database.PostgreSQL.Opium as Opium +import qualified Database.PostgreSQL.Opium.FromRow as Opium.FromRow + +shouldHaveColumns + :: Opium.FromRow a + => Proxy a + -> LibPQ.Connection + -> ByteString + -> [LibPQ.Column] + -> IO () +shouldHaveColumns proxy conn query expectedColumns = do + Just result <- LibPQ.execParams conn query [] LibPQ.Binary + columnTable <- Opium.getColumnTable proxy result + let actualColumns = fmap (map fst . Opium.FromRow.toListColumnTable) columnTable + actualColumns `shouldBe` Right expectedColumns + +-- These test the mapping from Result to ColumnTable/FromRow instances. + -- They use the raw LibPQ connection for retrieving the Results. +spec :: SpecWith Opium.Connection +spec = aroundWith unsafeWithRawConnection $ do + describe "getColumnTable" $ do + it "Gets the column table for a result" $ \conn -> do + shouldHaveColumns @Person Proxy conn + "SELECT name, age FROM person" + [0, 1] + + it "Gets the numbers right for funky configurations" $ \conn -> do + shouldHaveColumns @Person Proxy conn + "SELECT age, name FROM person" + [1, 0] + + shouldHaveColumns @Person Proxy conn + "SELECT 0 AS a, 1 AS b, 2 AS c, age, 4 AS d, name FROM person" + [5, 3] + + it "Fails for missing columns" $ \conn -> do + Just result <- LibPQ.execParams conn "SELECT 0 AS a FROM person" [] LibPQ.Binary + columnTable <- Opium.getColumnTable @Person Proxy result + columnTable `shouldBe` Left (Opium.ErrorMissingColumn "name") + + describe "fromRow" $ do + it "Decodes rows in a Result" $ \conn -> do + Just result <- LibPQ.execParams conn "SELECT * FROM person" [] LibPQ.Binary + Right columnTable <- Opium.getColumnTable @Person Proxy result + + row0 <- Opium.fromRow @Person result columnTable 0 + row0 `shouldBe` Right (Person "paul" 25) + + row1 <- Opium.fromRow @Person result columnTable 1 + row1 `shouldBe` Right (Person "albus" 103) + + it "Decodes NULL into Nothing for Maybes" $ \conn -> do + Just result <- LibPQ.execParams conn "SELECT NULL AS a" [] LibPQ.Binary + Right columnTable <- Opium.getColumnTable @MaybeTest Proxy result + + row <- Opium.fromRow result columnTable 0 + row `shouldBe` Right (MaybeTest Nothing) + + it "Decodes values into Just for Maybes" $ \conn -> do + Just result <- LibPQ.execParams conn "SELECT 'abc' AS a" [] LibPQ.Binary + Right columnTable <- Opium.getColumnTable @MaybeTest Proxy result + + row <- Opium.fromRow result columnTable 0 + row `shouldBe` Right (MaybeTest $ Just "abc") + + it "Works for many fields" $ \conn -> do + Just result <- LibPQ.execParams conn "SELECT 'abc' AS a, 42 AS b, 1.0::double precision AS c, 'test' AS d, true AS e" [] LibPQ.Binary + Right columnTable <- Opium.getColumnTable @ManyFields Proxy result + + row <- Opium.fromRow result columnTable 0 + row `shouldBe` Right (ManyFields "abc" 42 1.0 "test" True) + + it "Decodes multiple records into a tuple" $ \conn -> do + Just result <- LibPQ.execParams conn "SELECT 'albus' AS name, 123 AS age, 42 AS only" [] LibPQ.Binary + Right columnTable <- Opium.getColumnTable @(Person, Only Int) Proxy result + + row <- Opium.fromRow @(Person, Only Int) result columnTable 0 + row `shouldBe` Right (Person "albus" 123, Only 42) diff --git a/test/Database/PostgreSQL/OpiumSpec.hs b/test/Database/PostgreSQL/OpiumSpec.hs index 7983ee4..472b302 100644 --- a/test/Database/PostgreSQL/OpiumSpec.hs +++ b/test/Database/PostgreSQL/OpiumSpec.hs @@ -4,20 +4,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} -module Database.PostgreSQL.OpiumSpec (spec) where +module Database.PostgreSQL.OpiumSpec (ManyFields (..), MaybeTest (..), Person (..), Only (..), spec) where -import Data.ByteString (ByteString) import Data.Either (isLeft) import Data.Functor.Identity (Identity (..)) -import Data.Proxy (Proxy (..)) import Data.Text (Text) -import Database.PostgreSQL.LibPQ (Connection) import GHC.Generics (Generic) import Test.Hspec (SpecWith, describe, it, shouldBe, shouldSatisfy) import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Database.PostgreSQL.Opium as Opium -import qualified Database.PostgreSQL.Opium.FromRow as Opium.FromRow data Person = Person { name :: Text @@ -55,80 +51,8 @@ newtype Only a = Only instance Opium.FromField a => Opium.FromRow (Only a) where -shouldHaveColumns - :: Opium.FromRow a - => Proxy a - -> Connection - -> ByteString - -> [LibPQ.Column] - -> IO () -shouldHaveColumns proxy conn query expectedColumns = do - Just result <- LibPQ.execParams conn query [] LibPQ.Binary - columnTable <- Opium.getColumnTable proxy result - let actualColumns = fmap (map fst . Opium.FromRow.toListColumnTable) columnTable - actualColumns `shouldBe` Right expectedColumns - -spec :: SpecWith Connection +spec :: SpecWith Opium.Connection spec = do - describe "getColumnTable" $ do - it "Gets the column table for a result" $ \conn -> do - shouldHaveColumns @Person Proxy conn - "SELECT name, age FROM person" - [0, 1] - - it "Gets the numbers right for funky configurations" $ \conn -> do - shouldHaveColumns @Person Proxy conn - "SELECT age, name FROM person" - [1, 0] - - shouldHaveColumns @Person Proxy conn - "SELECT 0 AS a, 1 AS b, 2 AS c, age, 4 AS d, name FROM person" - [5, 3] - - it "Fails for missing columns" $ \conn -> do - Just result <- LibPQ.execParams conn "SELECT 0 AS a FROM person" [] LibPQ.Binary - columnTable <- Opium.getColumnTable @Person Proxy result - columnTable `shouldBe` Left (Opium.ErrorMissingColumn "name") - - describe "fromRow" $ do - it "Decodes rows in a Result" $ \conn -> do - Just result <- LibPQ.execParams conn "SELECT * FROM person" [] LibPQ.Binary - Right columnTable <- Opium.getColumnTable @Person Proxy result - - row0 <- Opium.fromRow @Person result columnTable 0 - row0 `shouldBe` Right (Person "paul" 25) - - row1 <- Opium.fromRow @Person result columnTable 1 - row1 `shouldBe` Right (Person "albus" 103) - - it "Decodes NULL into Nothing for Maybes" $ \conn -> do - Just result <- LibPQ.execParams conn "SELECT NULL AS a" [] LibPQ.Binary - Right columnTable <- Opium.getColumnTable @MaybeTest Proxy result - - row <- Opium.fromRow result columnTable 0 - row `shouldBe` Right (MaybeTest Nothing) - - it "Decodes values into Just for Maybes" $ \conn -> do - Just result <- LibPQ.execParams conn "SELECT 'abc' AS a" [] LibPQ.Binary - Right columnTable <- Opium.getColumnTable @MaybeTest Proxy result - - row <- Opium.fromRow result columnTable 0 - row `shouldBe` Right (MaybeTest $ Just "abc") - - it "Works for many fields" $ \conn -> do - Just result <- LibPQ.execParams conn "SELECT 'abc' AS a, 42 AS b, 1.0::double precision AS c, 'test' AS d, true AS e" [] LibPQ.Binary - Right columnTable <- Opium.getColumnTable @ManyFields Proxy result - - row <- Opium.fromRow result columnTable 0 - row `shouldBe` Right (ManyFields "abc" 42 1.0 "test" True) - - it "Decodes multiple records into a tuple" $ \conn -> do - Just result <- LibPQ.execParams conn "SELECT 'albus' AS name, 123 AS age, 42 AS only" [] LibPQ.Binary - Right columnTable <- Opium.getColumnTable @(Person, Only Int) Proxy result - - row <- Opium.fromRow @(Person, Only Int) result columnTable 0 - row `shouldBe` Right (Person "albus" 123, Only 42) - describe "fetch" $ do it "Passes numbered parameters and retrieves a list of rows" $ \conn -> do rows <- Opium.fetch "SELECT ($1 + $2) AS only" (17 :: Int, 25 :: Int) conn @@ -182,3 +106,8 @@ spec = do it "Does not accept two rows when Maybe is the row container type" $ \conn -> do row <- Opium.fetch_ @(Only Int) @Maybe "SELECT 17 AS only UNION ALL SELECT 25 AS only" conn row `shouldSatisfy` isLeft + + describe "close" $ do + it "Does not crash when called twice on the same connection" $ \conn -> do + Opium.close conn + Opium.close conn diff --git a/test/SpecHook.hs b/test/SpecHook.hs index 9fc7d3e..102a7e6 100644 --- a/test/SpecHook.hs +++ b/test/SpecHook.hs @@ -3,16 +3,16 @@ module SpecHook (hook) where import Control.Exception (bracket) -import Database.PostgreSQL.LibPQ (Connection) import System.Environment (lookupEnv) import Test.Hspec (Spec, SpecWith, around) import Text.Printf (printf) import qualified Data.Text as Text import qualified Data.Text.Encoding as Encoding -import qualified Database.PostgreSQL.LibPQ as LibPQ -setupConnection :: IO Connection +import qualified Database.PostgreSQL.Opium as Opium + +setupConnection :: IO Opium.Connection setupConnection = do Just dbUser <- lookupEnv "DB_USER" Just dbPass <- lookupEnv "DB_PASS" @@ -20,24 +20,17 @@ setupConnection = do Just dbPort <- lookupEnv "DB_PORT" let dsn = printf "host=localhost user=%s password=%s dbname=%s port=%s" dbUser dbPass dbName dbPort - conn <- LibPQ.connectdb $ Encoding.encodeUtf8 $ Text.pack dsn - _ <- LibPQ.setClientEncoding conn "UTF8" + conn <- Opium.connect $ Encoding.encodeUtf8 $ Text.pack dsn - _ <- LibPQ.exec conn "CREATE TABLE person (name TEXT NOT NULL, age INT NOT NULL, score DOUBLE PRECISION NOT NULL, motto TEXT)" - _ <- LibPQ.exec conn "INSERT INTO person VALUES ('paul', 25, 30), ('albus', 103, 50.42)" + Right _ <- Opium.execute_ "CREATE TABLE person (name TEXT NOT NULL, age INT NOT NULL, score DOUBLE PRECISION NOT NULL, motto TEXT)" conn + Right _ <- Opium.execute_ "INSERT INTO person VALUES ('paul', 25, 30), ('albus', 103, 50.42)" conn pure conn -teardownConnection :: Connection -> IO () +teardownConnection :: Opium.Connection -> IO () teardownConnection conn = do - _ <- LibPQ.exec conn "DROP TABLE person" - LibPQ.finish conn + Right _ <- Opium.execute_ "DROP TABLE person" conn + Opium.close conn -class SpecInput a where - hook :: SpecWith a -> Spec - -instance SpecInput Connection where - hook = around $ bracket setupConnection teardownConnection - -instance SpecInput () where - hook = id +hook :: SpecWith Opium.Connection -> Spec +hook = around $ bracket setupConnection teardownConnection