diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,6 @@ +# 0.10.0 - Major overhaul +* Transactions now are only retried in case of the "serialization_failure" (40001) error + # 0.9.1 * The Unknown type got implemented diff --git a/competition/Main.hs b/competition/Main.hs --- a/competition/Main.hs +++ b/competition/Main.hs @@ -2,12 +2,13 @@ import MTLPrelude import Control.DeepSeq import Control.Monad.Trans.Control +import Control.Monad.Trans.Either import Data.Text (Text) import Data.Vector (Vector) import Data.Time import CriterionPlus import qualified Hasql as H -import qualified Hasql.Postgres as H +import qualified Hasql.Postgres as HP import qualified ListT import qualified Database.PostgreSQL.Simple as P import qualified Database.PostgreSQL.Simple.SqlQQ as P @@ -34,19 +35,19 @@ subject "hasql" $ do pause - H.session (H.ParamSettings host port user password db) (fromJust $ H.sessionSettings 1 30) $ do + hSession (HP.ParamSettings host port user password db) (fromJust $ H.poolSettings 1 30) $ do H.tx Nothing $ do - H.unit [H.q|DROP TABLE IF EXISTS a|] - H.unit [H.q|CREATE TABLE a (id SERIAL NOT NULL, - name VARCHAR NOT NULL, - birthday DATE, - PRIMARY KEY (id))|] + H.unitTx [H.stmt|DROP TABLE IF EXISTS a|] + H.unitTx [H.stmt|CREATE TABLE a (id SERIAL NOT NULL, + name VARCHAR NOT NULL, + birthday DATE, + PRIMARY KEY (id))|] forM_ rows $ \(name, birthday) -> do - H.unit $ [H.q|INSERT INTO a (name, birthday) VALUES (?, ?)|] name birthday + H.unitTx $ [H.stmt|INSERT INTO a (name, birthday) VALUES (?, ?)|] name birthday lift $ continue replicateM_ 100 $ do r <- H.tx Nothing $ do - H.list $ [H.q|SELECT * FROM a|] :: H.Tx H.Postgres s [(Int, Text, Day)] + fmap toList $ H.vectorTx $ [H.stmt|SELECT * FROM a|] :: H.Tx HP.Postgres s [(Int, Text, Day)] deepseq r $ return () lift $ pause @@ -110,22 +111,22 @@ subject "hasql" $ do pause - H.session (H.ParamSettings host port user password db) (fromJust $ H.sessionSettings 1 30) $ do + hSession (HP.ParamSettings host port user password db) (fromJust $ H.poolSettings 1 30) $ do H.tx Nothing $ do - H.unit [H.q|DROP TABLE IF EXISTS a|] - H.unit [H.q|CREATE TABLE a (id SERIAL NOT NULL, - name VARCHAR NOT NULL, - birthday DATE, - PRIMARY KEY (id))|] + H.unitTx [H.stmt|DROP TABLE IF EXISTS a|] + H.unitTx [H.stmt|CREATE TABLE a (id SERIAL NOT NULL, + name VARCHAR NOT NULL, + birthday DATE, + PRIMARY KEY (id))|] lift $ continue replicateM_ 1000 $ do H.tx Nothing $ do - H.list $ - [H.q|SELECT * FROM a WHERE id > ? AND id < ? AND birthday != ?|] + fmap toList $ H.vectorTx $ + [H.stmt|SELECT * FROM a WHERE id > ? AND id < ? AND birthday != ?|] (1000 :: Int) (0 :: Int) (day) - :: H.Tx H.Postgres s [(Int, Text, Day)] + :: H.Tx HP.Postgres s [(Int, Text, Day)] lift $ pause subject "postgresql-simple" $ do @@ -183,22 +184,22 @@ subject "hasql" $ do pause - H.session (H.ParamSettings host port user password db) (fromJust $ H.sessionSettings 1 30) $ do + hSession (HP.ParamSettings host port user password db) (fromJust $ H.poolSettings 1 30) $ do H.tx Nothing $ do - H.unit [H.q|DROP TABLE IF EXISTS a|] - H.unit [H.q|CREATE TABLE a (id SERIAL NOT NULL, balance INT8, PRIMARY KEY (id))|] + H.unitTx [H.stmt|DROP TABLE IF EXISTS a|] + H.unitTx [H.stmt|CREATE TABLE a (id SERIAL NOT NULL, balance INT8, PRIMARY KEY (id))|] replicateM_ users $ do - H.unit [H.q|INSERT INTO a (balance) VALUES (0)|] + H.unitTx [H.stmt|INSERT INTO a (balance) VALUES (0)|] lift $ continue forM_ transfers $ \(id1, id2) -> do - H.tx (Just (H.Serializable, True)) $ do + H.tx (Just (H.Serializable, Just True)) $ do runMaybeT $ do do - Identity balance <- MaybeT $ H.single $ [H.q|SELECT balance FROM a WHERE id=?|] id1 - lift $ H.unit $ [H.q|UPDATE a SET balance=? WHERE id=?|] (balance - amount) id1 + Identity balance <- MaybeT $ H.maybeTx $ [H.stmt|SELECT balance FROM a WHERE id=?|] id1 + lift $ H.unitTx $ [H.stmt|UPDATE a SET balance=? WHERE id=?|] (balance - amount) id1 do - Identity balance <- MaybeT $ H.single $ [H.q|SELECT balance FROM a WHERE id=?|] id2 - lift $ H.unit $ [H.q|UPDATE a SET balance=? WHERE id=?|] (balance + amount) id2 + Identity balance <- MaybeT $ H.maybeTx $ [H.stmt|SELECT balance FROM a WHERE id=?|] id2 + lift $ H.unitTx $ [H.stmt|UPDATE a SET balance=? WHERE id=?|] (balance + amount) id2 lift $ pause subject "postgresql-simple" $ do @@ -248,6 +249,22 @@ liftIO $ C.disconnect c +-- * Hasql utils +------------------------- + +hSession :: MonadBaseControl IO m => + HP.Settings -> H.PoolSettings -> H.Session HP.Postgres m r -> + m (Either (H.SessionError HP.Postgres) r) +hSession s1 s2 m = + control $ \unlift -> do + p <- H.acquirePool s1 s2 + r <- unlift $ H.session p m + H.releasePool p + return r + + +-- * DB data +------------------------- host = "localhost" port = 5432 diff --git a/hasql-postgres.cabal b/hasql-postgres.cabal --- a/hasql-postgres.cabal +++ b/hasql-postgres.cabal @@ -1,7 +1,7 @@ name: hasql-postgres version: - 0.9.1 + 0.10.0 synopsis: A "PostgreSQL" backend for the "hasql" library description: @@ -58,18 +58,18 @@ default-language: Haskell2010 other-modules: - Hasql.Postgres.Connector Hasql.Postgres.Prelude - Hasql.Postgres.ErrorCode Hasql.Postgres.PTI Hasql.Postgres.Mapping + Hasql.Postgres.Connector Hasql.Postgres.Statement - Hasql.Postgres.TemplateConverter - Hasql.Postgres.TemplateConverter.Parser + Hasql.Postgres.Statement.TemplateConverter + Hasql.Postgres.Statement.TemplateConverter.Parser Hasql.Postgres.Session.ResultProcessing - Hasql.Postgres.Session.Transaction Hasql.Postgres.Session.Execution + Hasql.Postgres.Session.Transaction exposed-modules: + Hasql.Postgres.ErrorCode Hasql.Postgres build-depends: -- template haskell: @@ -77,7 +77,7 @@ -- parsers: attoparsec >= 0.10 && < 0.13, -- database: - hasql-backend == 0.2.*, + hasql-backend == 0.3.*, postgresql-binary == 0.5.*, postgresql-libpq == 0.9.*, -- data: @@ -90,6 +90,7 @@ bytestring >= 0.10 && < 0.11, hashable >= 1.1 && < 1.3, -- control: + free >= 4.6 && < 5, either >= 4.3 && < 4.4, list-t < 0.5, mmorph == 1.0.*, @@ -143,14 +144,11 @@ postgresql-binary, hasql-postgres, hasql-backend, - hasql >= 0.4 && < 0.6, + hasql == 0.6.*, -- testing: hspec == 2.1.*, quickcheck-instances == 0.3.*, QuickCheck == 2.7.*, - -- concurrency: - SafeSemaphore == 0.10.*, - slave-thread == 0.1.*, -- data: vector == 0.10.*, old-locale == 1.0.*, @@ -160,6 +158,7 @@ bytestring >= 0.10 && < 0.11, hashable >= 1.1 && < 1.3, -- general: + either, list-t < 0.5, mtl-prelude < 3, base-prelude >= 0.1.3 && < 0.2, @@ -188,7 +187,7 @@ postgresql-simple == 0.4.*, hasql-postgres, hasql-backend, - hasql >= 0.4 && < 0.6, + hasql == 0.6.*, -- random: QuickCheck == 2.7.*, quickcheck-instances == 0.3.*, @@ -200,6 +199,7 @@ text >= 1 && < 1.3, scientific >= 0.2 && < 0.4, -- general: + either, monad-control >= 0.3 && < 1.1, deepseq == 1.3.*, list-t < 0.5, diff --git a/hspec/Main.hs b/hspec/Main.hs --- a/hspec/Main.hs +++ b/hspec/Main.hs @@ -2,19 +2,16 @@ import BasePrelude hiding (assert) import MTLPrelude +import Control.Monad.Trans.Either import Test.Hspec import Test.QuickCheck import Test.QuickCheck.Instances -import Hasql -import Hasql.Postgres (Postgres(..)) import Data.Time import qualified Data.Text import qualified Data.Text.Lazy import qualified Data.ByteString import qualified Data.ByteString.Lazy import qualified ListT -import qualified SlaveThread -import qualified Control.Concurrent.SSem as SSem import qualified Hasql.Backend as Backend import qualified Hasql as H import qualified Hasql.Postgres as HP @@ -38,137 +35,143 @@ it "wrongPort" $ do let backendSettings = HP.ParamSettings "localhost" 1 "postgres" "" "postgres" - poolSettings = fromJust $ sessionSettings 6 30 - io = - H.session backendSettings poolSettings $ do - H.tx Nothing $ H.unit [H.q|DROP TABLE IF EXISTS a|] - in - shouldThrow io $ \case - H.CantConnect _ -> True + poolSettings = fromJust $ H.poolSettings 6 30 + in do + r <- + session backendSettings poolSettings $ do + H.tx Nothing $ H.unitTx [H.stmt|DROP TABLE IF EXISTS a|] + shouldSatisfy r $ \case + Left (H.CxError _) -> True _ -> False it "sameStatementUsedOnDifferentTypes" $ do - session1 $ do - liftIO . (flip shouldBe) (Just (Identity ("abc" :: Text))) =<< do - H.tx Nothing $ H.single $ [H.q|SELECT ?|] ("abc" :: Text) - liftIO . (flip shouldBe) (Just (Identity True)) =<< do - H.tx Nothing $ H.single $ [H.q|SELECT ?|] True + flip shouldSatisfy isRight =<< do + session1 $ do + liftIO . (flip shouldBe) (Just (Identity ("abc" :: Text))) =<< do + H.tx Nothing $ H.maybeTx $ [H.stmt|SELECT ?|] ("abc" :: Text) + liftIO . (flip shouldBe) (Just (Identity True)) =<< do + H.tx Nothing $ H.maybeTx $ [H.stmt|SELECT ?|] True it "rendering" $ do let rows = [("A", 34525), ("B", 324987)] :: [(Text, Int)] - (flip shouldBe) (Just $ head rows) =<< do + (flip shouldBe) (Right $ Just $ head rows) =<< do session1 $ do H.tx Nothing $ do - H.unit [H.q|DROP TABLE IF EXISTS a|] - H.unit [H.q|CREATE TABLE a (id SERIAL NOT NULL, - name VARCHAR NOT NULL, - birthday INT8, - PRIMARY KEY (id))|] + H.unitTx [H.stmt|DROP TABLE IF EXISTS a|] + H.unitTx [H.stmt|CREATE TABLE a (id SERIAL NOT NULL, + name VARCHAR NOT NULL, + birthday INT8, + PRIMARY KEY (id))|] forM_ rows $ \(name, birthday) -> do - H.unit $ [H.q|INSERT INTO a (name, birthday) VALUES (?, ?)|] name birthday + H.unitTx $ [H.stmt|INSERT INTO a (name, birthday) VALUES (?, ?)|] name birthday H.tx Nothing $ do - H.single $ [H.q|SELECT name, birthday FROM a WHERE id = ? |] (1 :: Int) + H.maybeTx $ [H.stmt|SELECT name, birthday FROM a WHERE id = ? |] (1 :: Int) it "countEffects" $ do - (flip shouldBe) 100 =<< do + (flip shouldBe) (Right 100) =<< do session1 $ do - tx Nothing $ do - unit [q|DROP TABLE IF EXISTS a|] - unit [q|CREATE TABLE a (id SERIAL NOT NULL, name VARCHAR NOT NULL)|] + H.tx Nothing $ do + H.unitTx [H.stmt|DROP TABLE IF EXISTS a|] + H.unitTx [H.stmt|CREATE TABLE a (id SERIAL NOT NULL, name VARCHAR NOT NULL)|] replicateM_ 100 $ do - unit [q|INSERT INTO a (name) VALUES ('a')|] - count [q|DELETE FROM a|] + H.unitTx [H.stmt|INSERT INTO a (name) VALUES ('a')|] + H.countTx [H.stmt|DELETE FROM a|] it "autoIncrement" $ do - (flip shouldBe) (Just (1 :: Word64), Just (2 :: Word64)) =<< do - session1 $ tx Nothing $ do - unit [q|DROP TABLE IF EXISTS a|] - unit [q|CREATE TABLE a (id SERIAL NOT NULL, v INT8, PRIMARY KEY (id))|] - id1 <- (fmap . fmap) runIdentity $ single $ [q|INSERT INTO a (v) VALUES (1) RETURNING id|] - id2 <- (fmap . fmap) runIdentity $ single $ [q|INSERT INTO a (v) VALUES (2) RETURNING id|] + (flip shouldBe) (Right (Just (1 :: Word64), Just (2 :: Word64))) =<< do + session1 $ H.tx Nothing $ do + H.unitTx [H.stmt|DROP TABLE IF EXISTS a|] + H.unitTx [H.stmt|CREATE TABLE a (id SERIAL NOT NULL, v INT8, PRIMARY KEY (id))|] + id1 <- (fmap . fmap) runIdentity $ H.maybeTx $ [H.stmt|INSERT INTO a (v) VALUES (1) RETURNING id|] + id2 <- (fmap . fmap) runIdentity $ H.maybeTx $ [H.stmt|INSERT INTO a (v) VALUES (2) RETURNING id|] return (id1, id2) it "cursorResultsOrder" $ do - session1 $ do - r :: [Word] <- - tx (Just (ReadCommitted, False)) $ do - ListT.toList $ fmap runIdentity $ stream $ - [q|select oid from pg_type ORDER BY oid|] - liftIO $ (flip shouldBe) (sort r) r + flip shouldSatisfy (\case Right r -> (sort r :: [Word]) == r; _ -> False) =<< do + session1 $ do + H.tx (Just (H.ReadCommitted, Nothing)) $ do + ListT.toList . fmap runIdentity =<< do + H.streamTx $ [H.stmt|select oid from pg_type ORDER BY oid|] it "cursor" $ do - session1 $ do - r :: [(Word, Text)] <- - tx (Just (ReadCommitted, False)) $ do - ListT.toList $ stream $ - [q|select oid, typname from pg_type|] - r' :: [(Word, Text)] <- - tx (Just (ReadCommitted, False)) $ do - list $ [q|select oid, typname from pg_type|] - liftIO $ (flip shouldBe) r' r + flip shouldSatisfy isRight =<< do + session1 $ do + r :: [(Word, Text)] <- + H.tx (Just (H.ReadCommitted, Nothing)) $ do + ListT.toList =<< do H.streamTx $ [H.stmt|select oid, typname from pg_type|] + r' :: [(Word, Text)] <- + H.tx (Just (H.ReadCommitted, Nothing)) $ do + fmap toList $ H.vectorTx $ [H.stmt|select oid, typname from pg_type|] + liftIO $ (flip shouldBe) r' r it "select" $ do - session1 $ do - r :: [(Word, Text)] <- - tx Nothing $ do - list $ [q|select oid, typname from pg_type|] - liftIO $ (flip shouldBe) True $ not $ null r + (flip shouldSatisfy) (either (const False) (not . null)) =<< do + session1 $ do + fmap toList $ H.tx Nothing $ H.vectorTx $ + [H.stmt|select oid, typname from pg_type|] :: Session [(Word, Text)] describe "Mapping of" $ do describe "Enum" $ do it "casts text" $ do - session1 $ do - H.tx Nothing $ do - H.unit [H.q| DROP TYPE IF EXISTS mood |] - H.unit [H.q| CREATE TYPE mood AS ENUM ('sad', 'ok', 'happy') |] - liftIO . (flip shouldBe) (Just (Identity ("ok" :: Text))) =<< do - H.tx Nothing $ H.single $ [H.q|SELECT (? :: mood)|] ("ok" :: Text) + flip shouldSatisfy isRight =<< do + session1 $ do + H.tx Nothing $ do + H.unitTx [H.stmt| DROP TYPE IF EXISTS mood |] + H.unitTx [H.stmt| CREATE TYPE mood AS ENUM ('sad', 'ok', 'happy') |] + liftIO . (flip shouldBe) (Just (Identity ("ok" :: Text))) =<< do + H.tx Nothing $ H.maybeTx $ [H.stmt|SELECT (? :: mood)|] ("ok" :: Text) describe "Unknown" $ do it "encodes to enum" $ do - session1 $ do - H.tx Nothing $ do - H.unit [H.q| DROP TABLE IF EXISTS a |] - H.unit [H.q| DROP TYPE IF EXISTS mood |] - H.unit [H.q| CREATE TYPE mood AS ENUM ('sad', 'ok', 'happy') |] - H.unit [H.q| CREATE TABLE a (id SERIAL NOT NULL, - mood mood NOT NULL, - PRIMARY KEY (id)) |] - H.unit $ [H.q| INSERT INTO a (mood) VALUES (?) |] (HP.Unknown "ok") - H.unit $ [H.q| INSERT INTO a (mood) VALUES (?) |] (HP.Unknown "ok") - H.unit $ [H.q| INSERT INTO a (mood) VALUES (?) |] (HP.Unknown "happy") - liftIO . (flip shouldBe) ([1, 2] :: [Int]) . fmap runIdentity =<< do - H.tx Nothing $ H.list $ [H.q|SELECT id FROM a WHERE mood = ?|] (HP.Unknown "ok") + flip shouldSatisfy isRight =<< do + session1 $ do + H.tx Nothing $ do + H.unitTx [H.stmt| DROP TABLE IF EXISTS a |] + H.unitTx [H.stmt| DROP TYPE IF EXISTS mood |] + H.unitTx [H.stmt| CREATE TYPE mood AS ENUM ('sad', 'ok', 'happy') |] + H.unitTx [H.stmt| CREATE TABLE a (id SERIAL NOT NULL, + mood mood NOT NULL, + PRIMARY KEY (id)) |] + H.unitTx $ [H.stmt| INSERT INTO a (mood) VALUES (?) |] (HP.Unknown "ok") + H.unitTx $ [H.stmt| INSERT INTO a (mood) VALUES (?) |] (HP.Unknown "ok") + H.unitTx $ [H.stmt| INSERT INTO a (mood) VALUES (?) |] (HP.Unknown "happy") + liftIO . (flip shouldBe) ([1, 2] :: [Int]) . fmap runIdentity =<< do + H.tx Nothing $ fmap toList $ H.vectorTx $ + [H.stmt|SELECT id FROM a WHERE mood = ?|] (HP.Unknown "ok") it "encodes Int64 into \"int8\" using a \"postgresql-binary\" encoder" $ do - session1 $ tx Nothing $ unit $ - [q| SELECT (? :: int8) |] - (HP.Unknown . PBE.int8 . Left $ 12345) + flip shouldSatisfy isRight =<< do + session1 $ H.tx Nothing $ H.unitTx $ + [H.stmt| SELECT (? :: int8) |] + (HP.Unknown . PBE.int8 . Left $ 12345) it "does not encode Int64 into \"int4\" using a \"postgresql-binary\" encoder" $ do - (flip shouldThrow) (\case H.ErroneousResult _ -> True; _ -> False) $ - session1 $ tx Nothing $ unit $ - [q| SELECT (? :: int4)|] + flip shouldSatisfy (\case Left (H.TxError _) -> True; _ -> False) =<< do + session1 $ H.tx Nothing $ H.unitTx $ + [H.stmt| SELECT (? :: int4)|] (HP.Unknown . PBE.int8 . Left $ 12345) it "encodes Int64 into \"int8\" using a \"postgresql-binary\" encoder" $ do - session1 $ tx Nothing $ unit $ - [q| SELECT (? :: int8) |] - (HP.Unknown . PBE.int8 . Left $ 12345) + flip shouldSatisfy isRight =<< do + session1 $ H.tx Nothing $ H.unitTx $ + [H.stmt| SELECT (? :: int8) |] + (HP.Unknown . PBE.int8 . Left $ 12345) it "encodes Day into \"date\" using a \"postgresql-binary\" encoder" $ do - session1 $ tx Nothing $ unit $ - [q| SELECT (? :: date) |] - (HP.Unknown . PBE.date $ (read "1900-01-01" :: Day)) + flip shouldSatisfy isRight =<< do + session1 $ H.tx Nothing $ H.unitTx $ + [H.stmt| SELECT (? :: date) |] + (HP.Unknown . PBE.date $ (read "1900-01-01" :: Day)) describe "Maybe" $ do it "" $ do - session1 $ do - validMappingSession (Just '!') - validMappingSession (Nothing :: Maybe Bool) + flip shouldSatisfy isRight =<< do + session1 $ do + validMappingSession (Just '!') + validMappingSession (Nothing :: Maybe Bool) describe "List" $ do @@ -176,21 +179,24 @@ let v1 = [v2, v2] v2 = [Just 'a', Nothing, Just 'b'] - session1 $ do - validMappingSession v1 - validMappingSession v2 + flip shouldSatisfy isRight =<< do + session1 $ do + validMappingSession v1 + validMappingSession v2 it "2" $ do let v1 = [v2, v2] v2 = [Just (1 :: Int), Just 2, Nothing] - session1 $ do - validMappingSession v1 - validMappingSession v2 + flip shouldSatisfy isRight =<< do + session1 $ do + validMappingSession v1 + validMappingSession v2 it "3" $ do - session1 $ do - validMappingSession [" 'a' \"b\" \\c\\ " :: Text] + flip shouldSatisfy isRight =<< do + session1 $ do + validMappingSession [" 'a' \"b\" \\c\\ " :: Text] it "4" $ do let @@ -199,16 +205,17 @@ [Just 'a', Just 'b'], [Nothing, Just 'c'] ] - (flip shouldBe) (Just (Identity v1)) =<< do - session1 $ tx Nothing $ do - unit $ [q|DROP TABLE IF EXISTS a|] - unit $ [q|CREATE TABLE a ("v" char[][])|] - unit $ [q|INSERT INTO a (v) VALUES (?)|] v1 - single $ [q|SELECT v FROM a|] + (flip shouldBe) (Right (Just (Identity v1))) =<< do + session1 $ H.tx Nothing $ do + H.unitTx $ [H.stmt|DROP TABLE IF EXISTS a|] + H.unitTx $ [H.stmt|CREATE TABLE a ("v" char[][])|] + H.unitTx $ [H.stmt|INSERT INTO a (v) VALUES (?)|] v1 + H.maybeTx $ [H.stmt|SELECT v FROM a|] it "5" $ do - session1 $ do - validMappingSession [" 'a' \"b\" \\c\\ ф" :: ByteString] + flip shouldSatisfy isRight =<< do + session1 $ do + validMappingSession [" 'a' \"b\" \\c\\ ф" :: ByteString] it "ByteString" $ property $ \(x :: [ByteString]) -> mappingProp x @@ -249,22 +256,33 @@ -- ** Session ------------------------- +type Session = + H.Session HP.Postgres IO + selectSelf :: - Backend.Mapping Postgres a => - a -> Session Postgres s IO (Maybe a) + Backend.CxValue HP.Postgres a => + a -> Session (Maybe a) selectSelf v = - tx Nothing $ (fmap . fmap) runIdentity $ single $ [q| SELECT ? |] v + H.tx Nothing $ (fmap . fmap) runIdentity $ H.maybeTx $ [H.stmt| SELECT ? |] v -session1 :: (forall s. Session Postgres s IO r) -> IO r +session1 :: Session r -> IO (Either (H.SessionError HP.Postgres) r) session1 = session backendSettings poolSettings where backendSettings = HP.ParamSettings "localhost" 5432 "postgres" "" "postgres" - poolSettings = fromJust $ sessionSettings 6 30 + poolSettings = fromJust $ H.poolSettings 6 30 +session :: HP.Settings -> H.PoolSettings -> Session r -> IO (Either (H.SessionError HP.Postgres) r) +session s1 s2 m = + do + p <- H.acquirePool s1 s2 + r <- H.session p m + H.releasePool p + return r + validMappingSession :: - Backend.Mapping Postgres a => Typeable a => Show a => Eq a => - a -> Session Postgres s IO () + Backend.CxValue HP.Postgres a => Typeable a => Show a => Eq a => + a -> Session () validMappingSession v = selectSelf v >>= liftIO . (flip shouldBe) (Just v) @@ -278,8 +296,6 @@ where error = max (abs a) 1 / 100 -mappingProp :: (Show a, Eq a, Backend.Mapping Postgres a) => a -> Property +mappingProp :: (Show a, Eq a, Backend.CxValue HP.Postgres a) => a -> Property mappingProp v = - Right v === do - unsafePerformIO $ (try :: IO a -> IO (Either H.Error a)) $ fmap fromJust $ - session1 $ selectSelf v + Right (Just v) === do unsafePerformIO $ session1 $ selectSelf v diff --git a/library/Hasql/Postgres.hs b/library/Hasql/Postgres.hs --- a/library/Hasql/Postgres.hs +++ b/library/Hasql/Postgres.hs @@ -7,154 +7,249 @@ -- encoding which in the type system would seriously burden the API, -- so it was decided to make it the user's responsibility -- to make sure that certain conditions are satisfied during the runtime. --- Particularly this concerns the 'Backend.Mapping' instances of +-- Particularly this concerns the 'Bknd.CxValue' instances of -- @Maybe@, @[]@ and @Vector@. -- For details consult the docs on those instances. -- module Hasql.Postgres ( - Postgres(..), + Postgres, Connector.Settings(..), - Unknown(..) + CxError(..), + TxError(..), + Unknown(..), ) where import Hasql.Postgres.Prelude import qualified Database.PostgreSQL.LibPQ as PQ -import qualified Hasql.Backend as Backend +import qualified Hasql.Backend as Bknd import qualified Hasql.Postgres.Connector as Connector import qualified Hasql.Postgres.Statement as Statement import qualified Hasql.Postgres.PTI as PTI import qualified Hasql.Postgres.Mapping as Mapping import qualified Hasql.Postgres.Session.Transaction as Transaction import qualified Hasql.Postgres.Session.Execution as Execution +import qualified Hasql.Postgres.Session.ResultProcessing as ResultProcessing import qualified Language.Haskell.TH as TH -import qualified Data.Attoparsec.ByteString.Char8 as Atto import qualified Data.Text.Encoding as Text +import qualified Data.Vector as Vector import qualified ListT -- | --- Just an alias to settings, --- which is used as a more descriptive identifier type of the backend. -type Postgres = - Connector.Settings +-- A connection to PostgreSQL. +data Postgres = + Postgres { + connection :: !PQ.Connection, + executionEnv :: !Execution.Env, + transactionEnv :: !Transaction.Env, + mappingEnv :: !Mapping.Environment + } +data CxError = + -- | + -- Impossible to connect. + -- A clarification might be given in the attached byte string. + CantConnect (Maybe ByteString) | + -- | + -- Server is running an unsupported version of Postgres. + -- The parameter is the version in such a format, + -- where a value @80105@ identifies a version @8.1.5@. + UnsupportedVersion Int + deriving (Show, Eq) -instance Backend.Backend Postgres where - data StatementArgument Postgres = - StatementArgument PQ.Oid (Mapping.Environment -> Maybe ByteString) - data Result Postgres = - Result Mapping.Environment (Maybe ByteString) - data Connection Postgres = - Connection { - connection :: !PQ.Connection, - executionEnv :: !Execution.Env, - transactionEnv :: !Transaction.Env, - mappingEnv :: !Mapping.Environment - } - connect settings = - do - r <- Connector.open settings - c <- either (\e -> throwIO $ Backend.CantConnect $ fromString $ show e) return r - ee <- Execution.newEnv c - Connection <$> pure c <*> pure ee <*> Transaction.newEnv ee <*> getIntegerDatetimes c + +instance Bknd.Cx Postgres where + type CxSettings Postgres = + Connector.Settings + type CxError Postgres = + CxError + acquireCx settings = + runEitherT $ do + c <- EitherT $ fmap (mapLeft connectorErrorMapping) $ Connector.open settings + lift $ do + e <- Execution.newEnv c + Postgres <$> pure c <*> pure e <*> Transaction.newEnv e <*> getIntegerDatetimes c where getIntegerDatetimes c = - fmap parseResult $ PQ.parameterStatus c "integer_datetimes" + fmap decodeValue $ PQ.parameterStatus c "integer_datetimes" where - parseResult = + decodeValue = \case Just "on" -> True _ -> False - disconnect c = - PQ.finish (connection c) - execute s = - do s' <- liftStatement s - liftExecution $ Execution.unitResult =<< Execution.statement s' - executeAndGetMatrix s = - do s' <- liftStatement s - c <- id - (fmap . fmap . fmap . fmap) (Result (mappingEnv c)) $ liftExecution $ - Execution.vectorResult =<< Execution.statement s' - executeAndStream s = - do s' <- liftStatement s - c <- id - return $ return $ liftTransactionStream (Transaction.streamWithCursor s') c - executeAndCountEffects s = - do s' <- liftStatement s - liftExecution $ Execution.countResult =<< Execution.statement s' - beginTransaction (isolation, write) = - liftTransaction $ Transaction.beginTransaction (mapIsolation isolation, write) - where - mapIsolation = + connectorErrorMapping = \case - Backend.Serializable -> Statement.Serializable - Backend.RepeatableReads -> Statement.RepeatableRead - Backend.ReadCommitted -> Statement.ReadCommitted - Backend.ReadUncommitted -> Statement.ReadCommitted - finishTransaction commit = - liftTransaction $ Transaction.finishTransaction commit + Connector.BadStatus x -> CantConnect x + Connector.UnsupportedVersion x -> UnsupportedVersion x + releaseCx = + PQ.finish . connection --- | --- Just a convenience alias to a function on connection. --- Useful since most of the 'Backend' API is made up of such functions. -type M a = - Backend.Connection Postgres -> a +-- * Transactions +------------------------- -liftExecution :: Execution.M a -> M (IO a) +data TxError = + -- | + -- Received no response from the database. + NoResult !(Maybe ByteString) | + -- | + -- An error reported by the DB. Code, message, details, hint. + -- + -- * The SQLSTATE code for the error. The SQLSTATE code identifies the type of error that has occurred; it can be used by front-end applications to perform specific operations (such as error handling) in response to a particular database error. For a list of the possible SQLSTATE codes, see Appendix A. This field is not localizable, and is always present. + -- * The primary human-readable error message (typically one line). Always present. + -- * Detail: an optional secondary error message carrying more detail about the problem. Might run to multiple lines. + -- * Hint: an optional suggestion what to do about the problem. This is intended to differ from detail in that it offers advice (potentially inappropriate) rather than hard facts. Might run to multiple lines. + ErroneousResult !ByteString !ByteString !(Maybe ByteString) !(Maybe ByteString) | + -- | + -- The database returned an unexpected result. + -- Indicates an improper statement or a schema mismatch. + UnexpectedResult !Text | + -- | + -- An attempt to perform an action, + -- which requires a transaction context, without one. + -- + -- Currently it's only raised when trying to stream + -- without establishing a transaction. + NotInTransaction + deriving (Show, Eq) + + +instance Bknd.CxTx Postgres where + type TxError Postgres = + TxError + runTx p mode = + runEitherT . runMaybeT . flip runReaderT p . inTransaction mode . interpretTx + + +type Interpreter a = + ReaderT Postgres (MaybeT (EitherT TxError IO)) a + +liftExecution :: Execution.M a -> Interpreter a liftExecution m = - \c -> Execution.run (executionEnv c) m >>= either (throwIO . mapExecutionError) return + do + r <- ReaderT $ \p -> liftIO $ Execution.run (executionEnv p) m + either throwResultProcessingError return r -liftTransaction :: Transaction.M a -> M (IO a) +liftTransaction :: Transaction.M a -> Interpreter a liftTransaction m = - \c -> Transaction.run (transactionEnv c) m >>= either (throwIO . mapError) return + do + r <- ReaderT $ \p -> liftIO $ Transaction.run (transactionEnv p) m + either throwTransactionError return r where - mapError = + throwTransactionError = \case - Transaction.NotInTransaction -> Backend.NotInTransaction - Transaction.ExecutionError e -> mapExecutionError e + Transaction.NotInTransaction -> lift $ lift $ left $ NotInTransaction + Transaction.ResultProcessingError a -> throwResultProcessingError a -liftStatement :: Backend.Statement Postgres -> M Statement.Statement -liftStatement (template, arguments, preparable) c = - (,,) template (map liftArgument arguments) preparable - where - liftArgument (StatementArgument o f) = - (,) o ((,) <$> f (mappingEnv c) <*> pure PQ.Binary) +throwResultProcessingError :: ResultProcessing.Error -> Interpreter a +throwResultProcessingError = + \case + ResultProcessing.NoResult a -> lift $ lift $ left $ NoResult a + ResultProcessing.ErroneousResult a b c d -> lift $ lift $ left $ ErroneousResult a b c d + ResultProcessing.UnexpectedResult a -> lift $ lift $ left $ UnexpectedResult a + ResultProcessing.TransactionConflict -> lift $ mzero -liftTransactionStream :: Transaction.Stream -> M (Backend.Stream Postgres) -liftTransactionStream s c = - (fmap . fmap) (Result (mappingEnv c)) $ hoist (flip liftTransaction c) s +convertStatement :: Bknd.Stmt Postgres -> Interpreter Statement.Statement +convertStatement s = + asks $ \p -> + let + liftParam (StmtParam o f) = + (,) o ((,) <$> f (mappingEnv p) <*> pure PQ.Binary) + in + Statement.Statement + (Statement.UnicodeTemplate (Bknd.stmtTemplate s)) + (toList $ fmap liftParam $ Bknd.stmtParams s) + (Bknd.stmtPreparable s) -mapExecutionError :: Execution.Error -> Backend.Error -mapExecutionError = - \case - Execution.UnexpectedResult m -> Backend.UnexpectedResult m - Execution.ErroneousResult m -> Backend.ErroneousResult m - Execution.UnparsableTemplate t m -> Backend.UnparsableTemplate $ - "Message: " <> m <> "; " <> - "Template: " <> fromString (show t) - Execution.TransactionConflict -> Backend.TransactionConflict +interpretTx :: Bknd.Tx Postgres a -> Interpreter a +interpretTx = + iterTM $ \case + Bknd.UnitTx stmt next -> do + stmt' <- convertStatement stmt + liftExecution $ Execution.unitResult =<< Execution.statement stmt' + next + Bknd.CountTx stmt next -> do + stmt' <- convertStatement stmt + r <- liftExecution $ Execution.countResult =<< Execution.statement stmt' + next $ r + Bknd.VectorTx stmt next -> do + stmt' <- convertStatement stmt + r <- liftExecution $ Execution.vectorResult =<< Execution.statement stmt' + r' <- + asks $ \p -> + (fmap . fmap) (ResultValue (mappingEnv p)) $ r + next r' + Bknd.StreamTx stmt next -> do + stmt' <- convertStatement stmt + r <- liftTransaction $ Transaction.streamWithCursor stmt' + r' <- + asks $ \p -> + (fmap . fmap) (ResultValue (mappingEnv p)) $ + hoist (lift . flip runReaderT p . liftTransaction) $ + r + next r' +inTransaction :: Bknd.TxMode -> Interpreter a -> Interpreter a +inTransaction mode m = + do + liftTransaction $ beginTransaction + result <- ReaderT $ \p -> lift $ lift $ runEitherT $ runMaybeT $ flip runReaderT p $ m + case result of + Left e -> do + liftTransaction $ finishTransaction False + lift $ lift $ left $ e + Right Nothing -> do + liftTransaction $ finishTransaction False + mzero + Right (Just r) -> do + liftTransaction $ finishTransaction True + return r + where + (,) beginTransaction finishTransaction = + case mode of + Nothing -> + (,) (return ()) + (const (return ())) + Just (isolation, Nothing) -> + (,) (Transaction.beginTransaction (convertIsolation isolation, False)) + (Transaction.finishTransaction) + Just (isolation, Just commit) -> + (,) (Transaction.beginTransaction (convertIsolation isolation, True)) + (\commit' -> Transaction.finishTransaction (commit && commit')) + where + convertIsolation = + \case + Bknd.Serializable -> Statement.Serializable + Bknd.RepeatableReads -> Statement.RepeatableRead + Bknd.ReadCommitted -> Statement.ReadCommitted + Bknd.ReadUncommitted -> Statement.ReadCommitted + -- * Mappings ------------------------- -- Not using TH to generate instances -- to be able to document them. ------------------------- +data instance Bknd.ResultValue Postgres = + ResultValue !Mapping.Environment !(Maybe ByteString) -{-# INLINE renderValueUsingMapping #-} -renderValueUsingMapping :: Mapping.Mapping a => a -> Backend.StatementArgument Postgres -renderValueUsingMapping x = - StatementArgument +data instance Bknd.StmtParam Postgres = + StmtParam !PQ.Oid !(Mapping.Environment -> Maybe ByteString) + + +{-# INLINE encodeValueUsingMapping #-} +encodeValueUsingMapping :: Mapping.Mapping a => a -> Bknd.StmtParam Postgres +encodeValueUsingMapping x = + StmtParam (PTI.oidPQ $ Mapping.oid x) (flip Mapping.encode x) -{-# INLINE parseResultUsingMapping #-} -parseResultUsingMapping :: Mapping.Mapping a => Backend.Result Postgres -> Either Text a -parseResultUsingMapping (Result e x) = +{-# INLINE decodeValueUsingMapping #-} +decodeValueUsingMapping :: Mapping.Mapping a => Bknd.ResultValue Postgres -> Either Text a +decodeValueUsingMapping (ResultValue e x) = Mapping.decode e x -- | @@ -166,9 +261,9 @@ -- Multilevel 'Maybe's are not supported. -- E.g., a value @Just Nothing@ of type @(Maybe (Maybe a))@ -- will be encoded the same way as @Nothing@. -instance Mapping.Mapping a => Backend.Mapping Postgres (Maybe a) where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Mapping.Mapping a => Bknd.CxValue Postgres (Maybe a) where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to Postgres arrays. @@ -204,108 +299,108 @@ -- it will be mapped to an array of characters. -- So if you want to map to a textual type use 'Text' instead. -- -instance (Mapping.Mapping a, Mapping.ArrayMapping a) => Backend.Mapping Postgres [a] where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance (Mapping.Mapping a, Mapping.ArrayMapping a) => Bknd.CxValue Postgres [a] where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to Postgres' arrays. -- -- Same rules as for the list instance apply. -- Consult its docs for details. -instance (Mapping.Mapping a, Mapping.ArrayMapping a) => Backend.Mapping Postgres (Vector a) where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance (Mapping.Mapping a, Mapping.ArrayMapping a) => Bknd.CxValue Postgres (Vector a) where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @int8@. -instance Backend.Mapping Postgres Int where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres Int where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @int2@. -instance Backend.Mapping Postgres Int8 where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres Int8 where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @int2@. -instance Backend.Mapping Postgres Int16 where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres Int16 where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @int4@. -instance Backend.Mapping Postgres Int32 where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres Int32 where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @int8@. -instance Backend.Mapping Postgres Int64 where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres Int64 where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @int8@. -instance Backend.Mapping Postgres Word where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres Word where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @int2@. -instance Backend.Mapping Postgres Word8 where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres Word8 where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @int2@. -instance Backend.Mapping Postgres Word16 where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres Word16 where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @int4@. -instance Backend.Mapping Postgres Word32 where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres Word32 where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @int8@. -instance Backend.Mapping Postgres Word64 where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres Word64 where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @float4@. -instance Backend.Mapping Postgres Float where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres Float where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @float8@. -instance Backend.Mapping Postgres Double where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres Double where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @numeric@. -instance Backend.Mapping Postgres Scientific where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres Scientific where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @date@. -instance Backend.Mapping Postgres Day where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres Day where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @time@. -instance Backend.Mapping Postgres TimeOfDay where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres TimeOfDay where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @timetz@. @@ -315,15 +410,15 @@ -- However the \"time\" library does not contain any composite type, -- that fits the task, so we use a pair of 'TimeOfDay' and 'TimeZone' -- to represent a value on the Haskell's side. -instance Backend.Mapping Postgres (TimeOfDay, TimeZone) where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres (TimeOfDay, TimeZone) where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @timestamp@. -instance Backend.Mapping Postgres LocalTime where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres LocalTime where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @timestamptz@. @@ -335,58 +430,58 @@ -- to the currently set timezone, when dealt with in the text format. -- However this library bypasses the silent conversions -- and communicates with Postgres using the UTC values directly. -instance Backend.Mapping Postgres UTCTime where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres UTCTime where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @interval@. -instance Backend.Mapping Postgres DiffTime where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres DiffTime where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @char@. -- Note that it supports UTF-8 values. -instance Backend.Mapping Postgres Char where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres Char where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @text@. -instance Backend.Mapping Postgres Text where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres Text where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @text@. -instance Backend.Mapping Postgres LazyText where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres LazyText where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @bytea@. -instance Backend.Mapping Postgres ByteString where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres ByteString where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @bytea@. -instance Backend.Mapping Postgres LazyByteString where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres LazyByteString where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @bool@. -instance Backend.Mapping Postgres Bool where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres Bool where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- | -- Maps to @uuid@. -instance Backend.Mapping Postgres UUID where - renderValue = renderValueUsingMapping - parseResult = parseResultUsingMapping +instance Bknd.CxValue Postgres UUID where + encodeValue = encodeValueUsingMapping + decodeValue = decodeValueUsingMapping -- ** Custom types @@ -408,9 +503,9 @@ -- | -- Maps to @unknown@. -instance Backend.Mapping Postgres Unknown where - renderValue (Unknown x) = - StatementArgument (PTI.oidPQ (PTI.ptiOID (PTI.unknown))) (const $ Just x) - parseResult (Result _ x) = +instance Bknd.CxValue Postgres Unknown where + encodeValue (Unknown x) = + StmtParam (PTI.oidPQ (PTI.ptiOID (PTI.unknown))) (const $ Just x) + decodeValue (ResultValue _ x) = maybe (Left "Decoding a NULL to Unknown") (Right . Unknown) x diff --git a/library/Hasql/Postgres/Connector.hs b/library/Hasql/Postgres/Connector.hs --- a/library/Hasql/Postgres/Connector.hs +++ b/library/Hasql/Postgres/Connector.hs @@ -22,6 +22,7 @@ data Error = BadStatus (Maybe ByteString) | + -- | The server is running a too old a version of Postgres. UnsupportedVersion Int deriving (Show) diff --git a/library/Hasql/Postgres/ErrorCode.hs b/library/Hasql/Postgres/ErrorCode.hs --- a/library/Hasql/Postgres/ErrorCode.hs +++ b/library/Hasql/Postgres/ErrorCode.hs @@ -11,399 +11,631 @@ -- * Class 00 — Successful Completion ------------------------- +-- | Code \"00000\". successful_completion :: ErrorCode = "00000" -- * Class 01 — Warning ------------------------- +-- | Code \"01000\". warning :: ErrorCode = "01000" +-- | Code \"0100C\". dynamic_result_sets_returned :: ErrorCode = "0100C" +-- | Code \"01008\". implicit_zero_bit_padding :: ErrorCode = "01008" +-- | Code \"01003\". null_value_eliminated_in_set_function :: ErrorCode = "01003" +-- | Code \"01007\". privilege_not_granted :: ErrorCode = "01007" +-- | Code \"01006\". privilege_not_revoked :: ErrorCode = "01006" +-- | Code \"01004\". string_data_right_truncation :: ErrorCode = "01004" +-- | Code \"01P01\". deprecated_feature :: ErrorCode = "01P01" -- * Class 02 — No Data (this is also a warning class per the SQL standard) ------------------------- +-- | Code \"02000\". no_data :: ErrorCode = "02000" +-- | Code \"02001\". no_additional_dynamic_result_sets_returned :: ErrorCode = "02001" -- * Class 03 — SQL Statement Not Yet Complete ------------------------- +-- | Code \"03000\". sql_statement_not_yet_complete :: ErrorCode = "03000" -- * Class 08 — Connection Exception ------------------------- +-- | Code \"08000\". connection_exception :: ErrorCode = "08000" +-- | Code \"08003\". connection_does_not_exist :: ErrorCode = "08003" +-- | Code \"08006\". connection_failure :: ErrorCode = "08006" +-- | Code \"08001\". sqlclient_unable_to_establish_sqlconnection :: ErrorCode = "08001" +-- | Code \"08004\". sqlserver_rejected_establishment_of_sqlconnection :: ErrorCode = "08004" +-- | Code \"08007\". transaction_resolution_unknown :: ErrorCode = "08007" +-- | Code \"08P01\". protocol_violation :: ErrorCode = "08P01" -- * Class 09 — Triggered Action Exception ------------------------- +-- | Code \"09000\". triggered_action_exception :: ErrorCode = "09000" -- * Class 0A — Feature Not Supported ------------------------- +-- | Code \"0A000\". feature_not_supported :: ErrorCode = "0A000" -- * Class 0B — Invalid Transaction Initiation ------------------------- +-- | Code \"0B000\". invalid_transaction_initiation :: ErrorCode = "0B000" -- * Class 0F — Locator Exception ------------------------- +-- | Code \"0F000\". locator_exception :: ErrorCode = "0F000" +-- | Code \"0F001\". invalid_locator_specification :: ErrorCode = "0F001" -- * Class 0L — Invalid Grantor ------------------------- +-- | Code \"0L000\". invalid_grantor :: ErrorCode = "0L000" +-- | Code \"0LP01\". invalid_grant_operation :: ErrorCode = "0LP01" -- * Class 0P — Invalid Role Specification ------------------------- +-- | Code \"0P000\". invalid_role_specification :: ErrorCode = "0P000" -- * Class 0Z — Diagnostics Exception ------------------------- +-- | Code \"0Z000\". diagnostics_exception :: ErrorCode = "0Z000" +-- | Code \"0Z002\". stacked_diagnostics_accessed_without_active_handler :: ErrorCode = "0Z002" -- * Class 20 — Case Not Found ------------------------- +-- | Code \"20000\". case_not_found :: ErrorCode = "20000" -- * Class 21 — Cardinality Violation ------------------------- +-- | Code \"21000\". cardinality_violation :: ErrorCode = "21000" -- * Class 22 — Data Exception ------------------------- +-- | Code \"22000\". data_exception :: ErrorCode = "22000" +-- | Code \"2202E\". array_subscript_error :: ErrorCode = "2202E" +-- | Code \"22021\". character_not_in_repertoire :: ErrorCode = "22021" +-- | Code \"22008\". datetime_field_overflow :: ErrorCode = "22008" +-- | Code \"22012\". division_by_zero :: ErrorCode = "22012" +-- | Code \"22005\". error_in_assignment :: ErrorCode = "22005" +-- | Code \"2200B\". escape_character_conflict :: ErrorCode = "2200B" +-- | Code \"22022\". indicator_overflow :: ErrorCode = "22022" +-- | Code \"22015\". interval_field_overflow :: ErrorCode = "22015" +-- | Code \"2201E\". invalid_argument_for_logarithm :: ErrorCode = "2201E" +-- | Code \"22014\". invalid_argument_for_ntile_function :: ErrorCode = "22014" +-- | Code \"22016\". invalid_argument_for_nth_value_function :: ErrorCode = "22016" +-- | Code \"2201F\". invalid_argument_for_power_function :: ErrorCode = "2201F" +-- | Code \"2201G\". invalid_argument_for_width_bucket_function :: ErrorCode = "2201G" +-- | Code \"22018\". invalid_character_value_for_cast :: ErrorCode = "22018" +-- | Code \"22007\". invalid_datetime_format :: ErrorCode = "22007" +-- | Code \"22019\". invalid_escape_character :: ErrorCode = "22019" +-- | Code \"2200D\". invalid_escape_octet :: ErrorCode = "2200D" +-- | Code \"22025\". invalid_escape_sequence :: ErrorCode = "22025" +-- | Code \"22P06\". nonstandard_use_of_escape_character :: ErrorCode = "22P06" +-- | Code \"22010\". invalid_indicator_parameter_value :: ErrorCode = "22010" +-- | Code \"22023\". invalid_parameter_value :: ErrorCode = "22023" +-- | Code \"2201B\". invalid_regular_expression :: ErrorCode = "2201B" +-- | Code \"2201W\". invalid_row_count_in_limit_clause :: ErrorCode = "2201W" +-- | Code \"2201X\". invalid_row_count_in_result_offset_clause :: ErrorCode = "2201X" +-- | Code \"22009\". invalid_time_zone_displacement_value :: ErrorCode = "22009" +-- | Code \"2200C\". invalid_use_of_escape_character :: ErrorCode = "2200C" +-- | Code \"2200G\". most_specific_type_mismatch :: ErrorCode = "2200G" +-- | Code \"22004\". null_value_not_allowed :: ErrorCode = "22004" +-- | Code \"22002\". null_value_no_indicator_parameter :: ErrorCode = "22002" +-- | Code \"22003\". numeric_value_out_of_range :: ErrorCode = "22003" +-- | Code \"22026\". string_data_length_mismatch :: ErrorCode = "22026" +-- | Code \"22001\". string_data_right_truncation' :: ErrorCode = "22001" +-- | Code \"22011\". substring_error :: ErrorCode = "22011" +-- | Code \"22027\". trim_error :: ErrorCode = "22027" +-- | Code \"22024\". unterminated_c_string :: ErrorCode = "22024" +-- | Code \"2200F\". zero_length_character_string :: ErrorCode = "2200F" +-- | Code \"22P01\". floating_point_exception :: ErrorCode = "22P01" +-- | Code \"22P02\". invalid_text_representation :: ErrorCode = "22P02" +-- | Code \"22P03\". invalid_binary_representation :: ErrorCode = "22P03" +-- | Code \"22P04\". bad_copy_file_format :: ErrorCode = "22P04" +-- | Code \"22P05\". untranslatable_character :: ErrorCode = "22P05" +-- | Code \"2200L\". not_an_xml_document :: ErrorCode = "2200L" +-- | Code \"2200M\". invalid_xml_document :: ErrorCode = "2200M" +-- | Code \"2200N\". invalid_xml_content :: ErrorCode = "2200N" +-- | Code \"2200S\". invalid_xml_comment :: ErrorCode = "2200S" +-- | Code \"2200T\". invalid_xml_processing_instruction :: ErrorCode = "2200T" -- * Class 23 — Integrity Constraint Violation ------------------------- +-- | Code \"23000\". integrity_constraint_violation :: ErrorCode = "23000" +-- | Code \"23001\". restrict_violation :: ErrorCode = "23001" +-- | Code \"23502\". not_null_violation :: ErrorCode = "23502" +-- | Code \"23503\". foreign_key_violation :: ErrorCode = "23503" +-- | Code \"23505\". unique_violation :: ErrorCode = "23505" +-- | Code \"23514\". check_violation :: ErrorCode = "23514" +-- | Code \"23P01\". exclusion_violation :: ErrorCode = "23P01" -- * Class 24 — Invalid Cursor State ------------------------- +-- | Code \"24000\". invalid_cursor_state :: ErrorCode = "24000" -- * Class 25 — Invalid Transaction State ------------------------- +-- | Code \"25000\". invalid_transaction_state :: ErrorCode = "25000" +-- | Code \"25001\". active_sql_transaction :: ErrorCode = "25001" +-- | Code \"25002\". branch_transaction_already_active :: ErrorCode = "25002" +-- | Code \"25008\". held_cursor_requires_same_isolation_level :: ErrorCode = "25008" +-- | Code \"25003\". inappropriate_access_mode_for_branch_transaction :: ErrorCode = "25003" +-- | Code \"25004\". inappropriate_isolation_level_for_branch_transaction :: ErrorCode = "25004" +-- | Code \"25005\". no_active_sql_transaction_for_branch_transaction :: ErrorCode = "25005" +-- | Code \"25006\". read_only_sql_transaction :: ErrorCode = "25006" +-- | Code \"25007\". schema_and_data_statement_mixing_not_supported :: ErrorCode = "25007" +-- | Code \"25P01\". no_active_sql_transaction :: ErrorCode = "25P01" +-- | Code \"25P02\". in_failed_sql_transaction :: ErrorCode = "25P02" -- * Class 26 — Invalid SQL Statement Name ------------------------- +-- | Code \"26000\". invalid_sql_statement_name :: ErrorCode = "26000" -- * Class 27 — Triggered Data Change Violation ------------------------- +-- | Code \"27000\". triggered_data_change_violation :: ErrorCode = "27000" -- * Class 28 — Invalid Authorization Specification ------------------------- +-- | Code \"28000\". invalid_authorization_specification :: ErrorCode = "28000" +-- | Code \"28P01\". invalid_password :: ErrorCode = "28P01" -- * Class 2B — Dependent Privilege Descriptors Still Exist ------------------------- +-- | Code \"2B000\". dependent_privilege_descriptors_still_exist :: ErrorCode = "2B000" +-- | Code \"2BP01\". dependent_objects_still_exist :: ErrorCode = "2BP01" -- * Class 2D — Invalid Transaction Termination ------------------------- +-- | Code \"2D000\". invalid_transaction_termination :: ErrorCode = "2D000" -- * Class 2F — SQL Routine Exception ------------------------- +-- | Code \"2F000\". sql_routine_exception :: ErrorCode = "2F000" +-- | Code \"2F005\". function_executed_no_return_statement :: ErrorCode = "2F005" +-- | Code \"2F002\". modifying_sql_data_not_permitted :: ErrorCode = "2F002" +-- | Code \"2F003\". prohibited_sql_statement_attempted :: ErrorCode = "2F003" +-- | Code \"2F004\". reading_sql_data_not_permitted :: ErrorCode = "2F004" -- * Class 34 — Invalid Cursor Name ------------------------- +-- | Code \"34000\". invalid_cursor_name :: ErrorCode = "34000" -- * Class 38 — External Routine Exception ------------------------- +-- | Code \"38000\". external_routine_exception :: ErrorCode = "38000" +-- | Code \"38001\". containing_sql_not_permitted :: ErrorCode = "38001" +-- | Code \"38002\". modifying_sql_data_not_permitted' :: ErrorCode = "38002" +-- | Code \"38003\". prohibited_sql_statement_attempted' :: ErrorCode = "38003" +-- | Code \"38004\". reading_sql_data_not_permitted' :: ErrorCode = "38004" -- * Class 39 — External Routine Invocation Exception ------------------------- +-- | Code \"39000\". external_routine_invocation_exception :: ErrorCode = "39000" +-- | Code \"39001\". invalid_sqlstate_returned :: ErrorCode = "39001" +-- | Code \"39004\". null_value_not_allowed' :: ErrorCode = "39004" +-- | Code \"39P01\". trigger_protocol_violated :: ErrorCode = "39P01" +-- | Code \"39P02\". srf_protocol_violated :: ErrorCode = "39P02" -- * Class 3B — Savepoint Exception ------------------------- +-- | Code \"3B000\". savepoint_exception :: ErrorCode = "3B000" +-- | Code \"3B001\". invalid_savepoint_specification :: ErrorCode = "3B001" -- * Class 3D — Invalid Catalog Name ------------------------- +-- | Code \"3D000\". invalid_catalog_name :: ErrorCode = "3D000" -- * Class 3F — Invalid Schema Name ------------------------- +-- | Code \"3F000\". invalid_schema_name :: ErrorCode = "3F000" -- * Class 40 — Transaction Rollback ------------------------- +-- | Code \"40000\". transaction_rollback :: ErrorCode = "40000" +-- | Code \"40002\". transaction_integrity_constraint_violation :: ErrorCode = "40002" +-- | Code \"40001\". serialization_failure :: ErrorCode = "40001" +-- | Code \"40003\". statement_completion_unknown :: ErrorCode = "40003" +-- | Code \"40P01\". deadlock_detected :: ErrorCode = "40P01" -- * Class 42 — Syntax Error or Access Rule Violation ------------------------- +-- | Code \"42000\". syntax_error_or_access_rule_violation :: ErrorCode = "42000" +-- | Code \"42601\". syntax_error :: ErrorCode = "42601" +-- | Code \"42501\". insufficient_privilege :: ErrorCode = "42501" +-- | Code \"42846\". cannot_coerce :: ErrorCode = "42846" +-- | Code \"42803\". grouping_error :: ErrorCode = "42803" +-- | Code \"42P20\". windowing_error :: ErrorCode = "42P20" +-- | Code \"42P19\". invalid_recursion :: ErrorCode = "42P19" +-- | Code \"42830\". invalid_foreign_key :: ErrorCode = "42830" +-- | Code \"42602\". invalid_name :: ErrorCode = "42602" +-- | Code \"42622\". name_too_long :: ErrorCode = "42622" +-- | Code \"42939\". reserved_name :: ErrorCode = "42939" +-- | Code \"42804\". datatype_mismatch :: ErrorCode = "42804" +-- | Code \"42P18\". indeterminate_datatype :: ErrorCode = "42P18" +-- | Code \"42P21\". collation_mismatch :: ErrorCode = "42P21" +-- | Code \"42P22\". indeterminate_collation :: ErrorCode = "42P22" +-- | Code \"42809\". wrong_object_type :: ErrorCode = "42809" +-- | Code \"42703\". undefined_column :: ErrorCode = "42703" +-- | Code \"42883\". undefined_function :: ErrorCode = "42883" +-- | Code \"42P01\". undefined_table :: ErrorCode = "42P01" +-- | Code \"42P02\". undefined_parameter :: ErrorCode = "42P02" +-- | Code \"42704\". undefined_object :: ErrorCode = "42704" +-- | Code \"42701\". duplicate_column :: ErrorCode = "42701" +-- | Code \"42P03\". duplicate_cursor :: ErrorCode = "42P03" +-- | Code \"42P04\". duplicate_database :: ErrorCode = "42P04" +-- | Code \"42723\". duplicate_function :: ErrorCode = "42723" +-- | Code \"42P05\". duplicate_prepared_statement :: ErrorCode = "42P05" +-- | Code \"42P06\". duplicate_schema :: ErrorCode = "42P06" +-- | Code \"42P07\". duplicate_table :: ErrorCode = "42P07" +-- | Code \"42712\". duplicate_alias :: ErrorCode = "42712" +-- | Code \"42710\". duplicate_object :: ErrorCode = "42710" +-- | Code \"42702\". ambiguous_column :: ErrorCode = "42702" +-- | Code \"42725\". ambiguous_function :: ErrorCode = "42725" +-- | Code \"42P08\". ambiguous_parameter :: ErrorCode = "42P08" +-- | Code \"42P09\". ambiguous_alias :: ErrorCode = "42P09" +-- | Code \"42P10\". invalid_column_reference :: ErrorCode = "42P10" +-- | Code \"42611\". invalid_column_definition :: ErrorCode = "42611" +-- | Code \"42P11\". invalid_cursor_definition :: ErrorCode = "42P11" +-- | Code \"42P12\". invalid_database_definition :: ErrorCode = "42P12" +-- | Code \"42P13\". invalid_function_definition :: ErrorCode = "42P13" +-- | Code \"42P14\". invalid_prepared_statement_definition :: ErrorCode = "42P14" +-- | Code \"42P15\". invalid_schema_definition :: ErrorCode = "42P15" +-- | Code \"42P16\". invalid_table_definition :: ErrorCode = "42P16" +-- | Code \"42P17\". invalid_object_definition :: ErrorCode = "42P17" -- * Class 44 — WITH CHECK OPTION Violation ------------------------- +-- | Code \"44000\". with_check_option_violation :: ErrorCode = "44000" -- * Class 53 — Insufficient Resources ------------------------- +-- | Code \"53000\". insufficient_resources :: ErrorCode = "53000" +-- | Code \"53100\". disk_full :: ErrorCode = "53100" +-- | Code \"53200\". out_of_memory :: ErrorCode = "53200" +-- | Code \"53300\". too_many_connections :: ErrorCode = "53300" +-- | Code \"53400\". configuration_limit_exceeded :: ErrorCode = "53400" -- * Class 54 — Program Limit Exceeded ------------------------- +-- | Code \"54000\". program_limit_exceeded :: ErrorCode = "54000" +-- | Code \"54001\". statement_too_complex :: ErrorCode = "54001" +-- | Code \"54011\". too_many_columns :: ErrorCode = "54011" +-- | Code \"54023\". too_many_arguments :: ErrorCode = "54023" -- * Class 55 — Object Not In Prerequisite State ------------------------- +-- | Code \"55000\". object_not_in_prerequisite_state :: ErrorCode = "55000" +-- | Code \"55006\". object_in_use :: ErrorCode = "55006" +-- | Code \"55P02\". cant_change_runtime_param :: ErrorCode = "55P02" +-- | Code \"55P03\". lock_not_available :: ErrorCode = "55P03" -- * Class 57 — Operator Intervention ------------------------- +-- | Code \"57000\". operator_intervention :: ErrorCode = "57000" +-- | Code \"57014\". query_canceled :: ErrorCode = "57014" +-- | Code \"57P01\". admin_shutdown :: ErrorCode = "57P01" +-- | Code \"57P02\". crash_shutdown :: ErrorCode = "57P02" +-- | Code \"57P03\". cannot_connect_now :: ErrorCode = "57P03" +-- | Code \"57P04\". database_dropped :: ErrorCode = "57P04" -- * Class 58 — System Error (errors external to PostgreSQL itself) ------------------------- +-- | Code \"58000\". system_error :: ErrorCode = "58000" +-- | Code \"58030\". io_error :: ErrorCode = "58030" +-- | Code \"58P01\". undefined_file :: ErrorCode = "58P01" +-- | Code \"58P02\". duplicate_file :: ErrorCode = "58P02" -- * Class F0 — Configuration File Error ------------------------- +-- | Code \"F0000\". config_file_error :: ErrorCode = "F0000" +-- | Code \"F0001\". lock_file_exists :: ErrorCode = "F0001" -- * Class HV — Foreign Data Wrapper Error (SQL/MED) ------------------------- +-- | Code \"HV000\". fdw_error :: ErrorCode = "HV000" +-- | Code \"HV005\". fdw_column_name_not_found :: ErrorCode = "HV005" +-- | Code \"HV002\". fdw_dynamic_parameter_value_needed :: ErrorCode = "HV002" +-- | Code \"HV010\". fdw_function_sequence_error :: ErrorCode = "HV010" +-- | Code \"HV021\". fdw_inconsistent_descriptor_information :: ErrorCode = "HV021" +-- | Code \"HV024\". fdw_invalid_attribute_value :: ErrorCode = "HV024" +-- | Code \"HV007\". fdw_invalid_column_name :: ErrorCode = "HV007" +-- | Code \"HV008\". fdw_invalid_column_number :: ErrorCode = "HV008" +-- | Code \"HV004\". fdw_invalid_data_type :: ErrorCode = "HV004" +-- | Code \"HV006\". fdw_invalid_data_type_descriptors :: ErrorCode = "HV006" +-- | Code \"HV091\". fdw_invalid_descriptor_field_identifier :: ErrorCode = "HV091" +-- | Code \"HV00B\". fdw_invalid_handle :: ErrorCode = "HV00B" +-- | Code \"HV00C\". fdw_invalid_option_index :: ErrorCode = "HV00C" +-- | Code \"HV00D\". fdw_invalid_option_name :: ErrorCode = "HV00D" +-- | Code \"HV090\". fdw_invalid_string_length_or_buffer_length :: ErrorCode = "HV090" +-- | Code \"HV00A\". fdw_invalid_string_format :: ErrorCode = "HV00A" +-- | Code \"HV009\". fdw_invalid_use_of_null_pointer :: ErrorCode = "HV009" +-- | Code \"HV014\". fdw_too_many_handles :: ErrorCode = "HV014" +-- | Code \"HV001\". fdw_out_of_memory :: ErrorCode = "HV001" +-- | Code \"HV00P\". fdw_no_schemas :: ErrorCode = "HV00P" +-- | Code \"HV00J\". fdw_option_name_not_found :: ErrorCode = "HV00J" +-- | Code \"HV00K\". fdw_reply_handle :: ErrorCode = "HV00K" +-- | Code \"HV00Q\". fdw_schema_not_found :: ErrorCode = "HV00Q" +-- | Code \"HV00R\". fdw_table_not_found :: ErrorCode = "HV00R" +-- | Code \"HV00L\". fdw_unable_to_create_execution :: ErrorCode = "HV00L" +-- | Code \"HV00M\". fdw_unable_to_create_reply :: ErrorCode = "HV00M" +-- | Code \"HV00N\". fdw_unable_to_establish_connection :: ErrorCode = "HV00N" -- * Class P0 — PL/pgSQL Error ------------------------- +-- | Code \"P0000\". plpgsql_error :: ErrorCode = "P0000" +-- | Code \"P0001\". raise_exception :: ErrorCode = "P0001" +-- | Code \"P0002\". no_data_found :: ErrorCode = "P0002" +-- | Code \"P0003\". too_many_rows :: ErrorCode = "P0003" -- * Class XX — Internal Error ------------------------- +-- | Code \"XX000\". internal_error :: ErrorCode = "XX000" +-- | Code \"XX001\". data_corrupted :: ErrorCode = "XX001" +-- | Code \"XX002\". index_corrupted :: ErrorCode = "XX002" diff --git a/library/Hasql/Postgres/Prelude.hs b/library/Hasql/Postgres/Prelude.hs --- a/library/Hasql/Postgres/Prelude.hs +++ b/library/Hasql/Postgres/Prelude.hs @@ -12,18 +12,25 @@ -- base-prelude ------------------------- -import BasePrelude as Exports hiding (assert, left, right) +import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight) -- transformers ------------------------- import Control.Monad.IO.Class as Exports import Control.Monad.Trans.Class as Exports +import Control.Monad.Trans.Maybe as Exports hiding (liftListen, liftPass) import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch) -import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch) +import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) -- either ------------------------- import Control.Monad.Trans.Either as Exports +import Data.Either.Combinators as Exports + +-- free +------------------------- +import Control.Monad.Trans.Free as Exports +import Control.Monad.Free.TH as Exports -- list-t ------------------------- diff --git a/library/Hasql/Postgres/Session/Execution.hs b/library/Hasql/Postgres/Session/Execution.hs --- a/library/Hasql/Postgres/Session/Execution.hs +++ b/library/Hasql/Postgres/Session/Execution.hs @@ -4,7 +4,6 @@ import qualified Data.HashTable.IO as Hashtables import qualified Database.PostgreSQL.LibPQ as PQ import qualified Hasql.Postgres.Statement as Statement -import qualified Hasql.Postgres.TemplateConverter as TemplateConverter import qualified Hasql.Postgres.Session.ResultProcessing as ResultProcessing @@ -22,14 +21,14 @@ -- | -- Local statement key. data LocalKey = - LocalKey !ByteString ![Word32] + LocalKey !Statement.Template ![Word32] deriving (Show, Eq) instance Hashable LocalKey where hashWithSalt salt (LocalKey template types) = hashWithSalt salt template -localKey :: ByteString -> [PQ.Oid] -> LocalKey +localKey :: Statement.Template -> [PQ.Oid] -> LocalKey localKey t ol = LocalKey t (map oidMapper ol) where @@ -42,32 +41,22 @@ ByteString -data Error = - UnexpectedResult Text | - ErroneousResult Text | - UnparsableTemplate ByteString Text | - TransactionConflict - - -- * Monad ------------------------- newtype M r = - M (ReaderT Env (EitherT Error IO) r) + M (ReaderT Env (EitherT ResultProcessing.Error IO) r) deriving (Functor, Applicative, Monad, MonadIO) -run :: Env -> M r -> IO (Either Error r) +run :: Env -> M r -> IO (Either ResultProcessing.Error r) run e (M m) = runEitherT $ runReaderT m e -throwError :: Error -> M a -throwError = M . lift . left - -prepare :: ByteString -> [PQ.Oid] -> M RemoteKey -prepare s tl = +prepare :: Statement.Template -> ByteString -> [PQ.Oid] -> M RemoteKey +prepare k s tl = do (c, counter, table) <- M $ ask - let lk = localKey s tl + let lk = localKey k tl rk <- liftIO $ Hashtables.lookup table lk ($ rk) $ ($ return) $ maybe $ do w <- liftIO $ readIORef counter @@ -81,14 +70,12 @@ statement s = do (c, _, _) <- M $ ask - let (template, params, preparable) = s - convertedTemplate <- - either (throwError . UnparsableTemplate template) return $ - TemplateConverter.convert template + let (Statement.Statement template params preparable) = s + let convertedTemplate = Statement.preparedTemplate template case preparable of True -> do let (tl, vl) = unzip params - key <- prepare convertedTemplate tl + key <- prepare template convertedTemplate tl liftIO $ PQ.execPrepared c key vl PQ.Binary False -> do let params' = map (\(t, v) -> (\(vb, vf) -> (t, vb, vf)) <$> v) params @@ -97,13 +84,7 @@ liftResultProcessing :: ResultProcessing.M a -> M a liftResultProcessing m = M $ ReaderT $ \(c, _, _) -> - EitherT $ fmap (either (Left . mapError) Right) $ ResultProcessing.run c m - where - mapError = - \case - ResultProcessing.UnexpectedResult t -> UnexpectedResult t - ResultProcessing.ErroneousResult t -> ErroneousResult t - ResultProcessing.TransactionConflict -> TransactionConflict + EitherT $ ResultProcessing.run c m {-# INLINE unitResult #-} unitResult :: Maybe PQ.Result -> M () diff --git a/library/Hasql/Postgres/Session/ResultProcessing.hs b/library/Hasql/Postgres/Session/ResultProcessing.hs --- a/library/Hasql/Postgres/Session/ResultProcessing.hs +++ b/library/Hasql/Postgres/Session/ResultProcessing.hs @@ -3,12 +3,10 @@ import Hasql.Postgres.Prelude import qualified Database.PostgreSQL.LibPQ as PQ import qualified Hasql.Postgres.ErrorCode as ErrorCode -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE import qualified Data.Attoparsec.ByteString.Char8 as Atto +import qualified Data.ByteString as B import qualified Data.Vector as Vector import qualified Data.Vector.Mutable as MVector -import qualified ListT newtype M r = @@ -16,9 +14,23 @@ deriving (Functor, Applicative, Monad, MonadIO) data Error = - UnexpectedResult Text | - ErroneousResult Text | + -- | + -- Received no response from the database. + NoResult !(Maybe ByteString) | + -- | + -- An error reported by the DB. Code, message, details, hint. + -- + -- * The SQLSTATE code for the error. The SQLSTATE code identifies the type of error that has occurred; it can be used by front-end applications to perform specific operations (such as error handling) in response to a particular database error. For a list of the possible SQLSTATE codes, see Appendix A. This field is not localizable, and is always present. + -- * The primary human-readable error message (typically one line). Always present. + -- * Detail: an optional secondary error message carrying more detail about the problem. Might run to multiple lines. + -- * Hint: an optional suggestion what to do about the problem. This is intended to differ from detail in that it offers advice (potentially inappropriate) rather than hard facts. Might run to multiple lines. + ErroneousResult !ByteString !ByteString !(Maybe ByteString) !(Maybe ByteString) | + -- | + -- The database returned an unexpected result. + -- Indicates an improper statement or a schema mismatch. + UnexpectedResult !Text | TransactionConflict + deriving (Show) run :: PQ.Connection -> M r -> IO (Either Error r) run e (M m) = @@ -28,12 +40,7 @@ just = ($ return) $ maybe $ M $ do m <- lift $ ask >>= liftIO . PQ.errorMessage - left $ ErroneousResult $ case m of - Nothing -> - "Sending a command to the server failed" - Just m -> - "Sending a command to the server failed due to: " <> - TE.decodeLatin1 m + left $ NoResult $ m checkStatus :: (PQ.ExecStatus -> Bool) -> PQ.Result -> M () checkStatus g r = @@ -41,51 +48,28 @@ s <- liftIO $ PQ.resultStatus r unless (g s) $ do case s of - PQ.BadResponse -> failWithErroneousResult "Bad response" - PQ.NonfatalError -> failWithErroneousResult "Non-fatal error" - PQ.FatalError -> failWithErroneousResult "Fatal error" + PQ.BadResponse -> failWithErroneousResult + PQ.NonfatalError -> failWithErroneousResult + PQ.FatalError -> failWithErroneousResult _ -> M $ left $ UnexpectedResult $ "Unexpected result status: " <> (fromString $ show s) where - failWithErroneousResult status = + failWithErroneousResult = do - code <- liftIO $ PQ.resultErrorField r PQ.DiagSqlstate - let transactionConflict = - case code of - Just x -> - elem x $ - [ - ErrorCode.transaction_rollback, - ErrorCode.transaction_integrity_constraint_violation, - ErrorCode.serialization_failure, - ErrorCode.statement_completion_unknown, - ErrorCode.deadlock_detected - ] - Nothing -> - False - in when transactionConflict $ M $ left $ TransactionConflict - message <- liftIO $ PQ.resultErrorField r PQ.DiagMessagePrimary - detail <- liftIO $ PQ.resultErrorField r PQ.DiagMessageDetail - hint <- liftIO $ PQ.resultErrorField r PQ.DiagMessageHint - M $ left $ ErroneousResult $ erroneousResultMessage status code message detail hint - erroneousResultMessage status code message details hint = - formatFields fields - where - formatFields = - formatList . map formatField . catMaybes - where - formatList items = - T.intercalate "; " items <> "." - formatField (n, v) = - n <> ": \"" <> v <> "\"" - fields = - [ - Just ("Status", fromString $ show status), - fmap (("Code",) . TE.decodeLatin1) $ code, - fmap (("Message",) . TE.decodeLatin1) $ message, - fmap (("Details",) . TE.decodeLatin1) $ details, - fmap (("Hint",) . TE.decodeLatin1) $ hint - ] + code <- + fmap (fromMaybe ($bug "No code")) $ + liftIO $ PQ.resultErrorField r PQ.DiagSqlstate + let transactionConflict = code == ErrorCode.serialization_failure + when transactionConflict $ M $ left $ TransactionConflict + message <- + fmap (fromMaybe ($bug "No message")) $ + liftIO $ PQ.resultErrorField r PQ.DiagMessagePrimary + detail <- + liftIO $ PQ.resultErrorField r PQ.DiagMessageDetail + hint <- + liftIO $ PQ.resultErrorField r PQ.DiagMessageHint + M $ left $ ErroneousResult code message detail hint + unit :: PQ.Result -> M () unit r = checkStatus (\case PQ.CommandOk -> True; PQ.TuplesOk -> True; _ -> False) r @@ -93,9 +77,10 @@ count :: PQ.Result -> M Word64 count r = do checkStatus (\case PQ.CommandOk -> True; _ -> False) r - (liftIO $ PQ.cmdTuples r) >>= - maybe (M $ left $ UnexpectedResult $ "No number of affected rows") - (parseWord64) + r' <- liftIO $ PQ.cmdTuples r + maybe (M $ left $ UnexpectedResult $ "No number of affected rows") + (parseWord64) + (mfilter (not . B.null) r') parseWord64 :: ByteString -> M Word64 parseWord64 b = @@ -110,13 +95,13 @@ liftIO $ do nr <- PQ.ntuples r nc <- PQ.nfields r - mvx <- MVector.new (rowInt nr) + mvx <- MVector.unsafeNew (rowInt nr) forM_ [0..pred nr] $ \ir -> do - mvy <- MVector.new (colInt nc) + mvy <- MVector.unsafeNew (colInt nc) forM_ [0..pred nc] $ \ic -> do - MVector.write mvy (colInt ic) =<< PQ.getvalue r ir ic + MVector.unsafeWrite mvy (colInt ic) =<< PQ.getvalue r ir ic vy <- Vector.unsafeFreeze mvy - MVector.write mvx (rowInt ir) vy + MVector.unsafeWrite mvx (rowInt ir) vy Vector.unsafeFreeze mvx {-# INLINE colInt #-} diff --git a/library/Hasql/Postgres/Session/Transaction.hs b/library/Hasql/Postgres/Session/Transaction.hs --- a/library/Hasql/Postgres/Session/Transaction.hs +++ b/library/Hasql/Postgres/Session/Transaction.hs @@ -9,6 +9,7 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.Vector as Vector import qualified Hasql.Postgres.Session.Execution as Execution +import qualified Hasql.Postgres.Session.ResultProcessing as ResultProcessing import qualified Hasql.Postgres.Statement as Statement @@ -35,7 +36,7 @@ data Error = NotInTransaction | - ExecutionError Execution.Error + ResultProcessingError ResultProcessing.Error run :: Env -> M r -> IO (Either Error r) run e (M m) = @@ -47,7 +48,7 @@ liftExecution :: Execution.M a -> M a liftExecution m = M $ ReaderT $ \e -> - EitherT $ fmap (either (Left . ExecutionError) Right) $ + EitherT $ fmap (either (Left . ResultProcessingError) Right) $ Execution.run (executionEnv e) m -- | @@ -103,14 +104,15 @@ type Stream = ListT M (Vector (Maybe ByteString)) -streamWithCursor :: Statement.Statement -> Stream +streamWithCursor :: Statement.Statement -> M Stream streamWithCursor statement = do - cursor <- lift $ declareCursor statement - let loop = do - chunk <- lift $ fetchFromCursor cursor - guard $ not $ Vector.null chunk - Vector.foldl step mempty chunk <> loop - step z r = z <> pure r - in loop + cursor <- declareCursor statement + return $ + let loop = do + chunk <- lift $ fetchFromCursor cursor + guard $ not $ Vector.null chunk + Vector.foldl step mempty chunk <> loop + step z r = z <> pure r + in loop diff --git a/library/Hasql/Postgres/Statement.hs b/library/Hasql/Postgres/Statement.hs --- a/library/Hasql/Postgres/Statement.hs +++ b/library/Hasql/Postgres/Statement.hs @@ -2,14 +2,24 @@ import Hasql.Postgres.Prelude import qualified Database.PostgreSQL.LibPQ as L +import qualified Data.Text.Encoding as TE import qualified Data.ByteString as B import qualified Data.ByteString.Lazy.Builder as BB import qualified Data.ByteString.Lazy as BL +import qualified Hasql.Postgres.Statement.TemplateConverter as TC -type Statement = - (ByteString, [(ValueType, Value)], Preparable) +data Statement = + Statement Template [(ValueType, Value)] Preparable + deriving (Show, Eq, Generic) +data Template = + PreparedTemplate ByteString | + UnicodeTemplate Text + deriving (Show, Eq, Generic) + +instance Hashable Template + -- | -- Maybe a rendered value with its serialization format. -- 'Nothing' implies @NULL@. @@ -37,54 +47,68 @@ type TransactionMode = (Isolation, Bool) +preparedTemplate :: Template -> ByteString +preparedTemplate = + \case + PreparedTemplate b -> b + UnicodeTemplate t -> BL.toStrict $ BB.toLazyByteString $ TC.convert t +preparedTemplateBuilder :: Template -> BB.Builder +preparedTemplateBuilder = + \case + PreparedTemplate b -> BB.byteString b + UnicodeTemplate t -> TC.convert t + declareCursor :: Cursor -> Statement -> Statement -declareCursor cursor (template, values, preparable) = +declareCursor cursor (Statement template values preparable) = let template' = - "DECLARE " <> cursor <> " NO SCROLL CURSOR FOR " <> template - in (template', values, preparable) + PreparedTemplate $ BL.toStrict $ BB.toLazyByteString $ + BB.string7 "DECLARE " <> BB.byteString cursor <> BB.char7 ' ' <> + BB.string7 "NO SCROLL CURSOR FOR " <> preparedTemplateBuilder template + in Statement template' values preparable closeCursor :: Cursor -> Statement closeCursor cursor = - (template, [], False) + Statement template [] True where template = - "CLOSE " <> cursor + PreparedTemplate $ "CLOSE " <> cursor fetchFromCursor :: Cursor -> Statement fetchFromCursor cursor = - (template, [], False) + Statement template [] True where template = - "FETCH FORWARD 256 FROM " <> cursor + PreparedTemplate $ "FETCH FORWARD 256 FROM " <> cursor beginTransaction :: TransactionMode -> Statement beginTransaction (i, w) = - (template, [], True) + Statement template [] True where template = + PreparedTemplate $ BL.toStrict $ BB.toLazyByteString $ - mconcat $ intersperse (BB.char7 ' ') $ - [ - BB.string7 "BEGIN" - , - case i of - ReadCommitted -> BB.string7 "ISOLATION LEVEL READ COMMITTED" - RepeatableRead -> BB.string7 "ISOLATION LEVEL REPEATABLE READ" - Serializable -> BB.string7 "ISOLATION LEVEL SERIALIZABLE" - , - case w of - True -> BB.string7 "READ WRITE" - False -> BB.string7 "READ ONLY" - ] + mconcat $ intersperse (BB.char7 ' ') $ + [ + BB.string7 "BEGIN" + , + case i of + ReadCommitted -> BB.string7 "ISOLATION LEVEL READ COMMITTED" + RepeatableRead -> BB.string7 "ISOLATION LEVEL REPEATABLE READ" + Serializable -> BB.string7 "ISOLATION LEVEL SERIALIZABLE" + , + case w of + True -> BB.string7 "READ WRITE" + False -> BB.string7 "READ ONLY" + ] commitTransaction :: Statement commitTransaction = - ("COMMIT", [], True) + Statement (PreparedTemplate "COMMIT") [] True abortTransaction :: Statement abortTransaction = - ("ABORT", [], True) + Statement (PreparedTemplate "ABORT") [] True diff --git a/library/Hasql/Postgres/Statement/TemplateConverter.hs b/library/Hasql/Postgres/Statement/TemplateConverter.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Postgres/Statement/TemplateConverter.hs @@ -0,0 +1,29 @@ +module Hasql.Postgres.Statement.TemplateConverter where + +import Hasql.Postgres.Prelude +import qualified Data.Text.Encoding as TE +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Builder as BB +import qualified Data.ByteString.Lazy.Builder.ASCII as BB +import qualified Hasql.Postgres.Statement.TemplateConverter.Parser as Parser + + +-- | +-- +-- >>> BB.toLazyByteString $ convert "asdf ? \"'\\\"?'\" d 2??" +-- "asdf $1 \"'\\\"?'\" d 2$2$3" +convert :: Text -> BB.Builder +convert template = + either ($bug . showString "Unparsable template: " . shows template . + showString "; Error: " . show) id $ + do + parts <- Parser.run (TE.encodeUtf8 template) Parser.parts + return $ + mconcat $ ($ 1) $ evalState $ do + forM parts $ \case + Parser.Chunk c -> do + return c + Parser.Placeholder -> do + i <- get + put $ succ i + return $ BB.char8 '$' <> BB.wordDec i diff --git a/library/Hasql/Postgres/Statement/TemplateConverter/Parser.hs b/library/Hasql/Postgres/Statement/TemplateConverter/Parser.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Postgres/Statement/TemplateConverter/Parser.hs @@ -0,0 +1,39 @@ +module Hasql.Postgres.Statement.TemplateConverter.Parser where + +import Hasql.Postgres.Prelude +import Data.Attoparsec.ByteString.Char8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Builder as BB + + +data Part = + Chunk BB.Builder | + Placeholder + +run :: ByteString -> Parser a -> Either Text a +run input parser = + either (Left . fromString) Right $ parseOnly (parser <* endOfInput) input + +parts :: Parser [Part] +parts = + many (chunk <|> placeholder) + where + chunk = + fmap Chunk $ fmap mconcat $ many1 $ stringLit <|> (BB.char8 <$> notChar '?') + placeholder = + char '?' *> pure Placeholder + +stringLit :: Parser BB.Builder +stringLit = + do + quote <- + char '"' <|> char '\'' + contentBuilders <- + many $ + (BB.byteString <$> string "\\\\") <|> + (BB.byteString <$> string (fromString ['\\', quote])) <|> + (BB.char8 <$> notChar quote) + char quote + return $ + BB.char7 quote <> mconcat contentBuilders <> BB.char7 quote + diff --git a/library/Hasql/Postgres/TemplateConverter.hs b/library/Hasql/Postgres/TemplateConverter.hs deleted file mode 100644 --- a/library/Hasql/Postgres/TemplateConverter.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Hasql.Postgres.TemplateConverter where - -import Hasql.Postgres.Prelude -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Builder as BB -import qualified Data.ByteString.Lazy.Builder.ASCII as BB -import qualified Hasql.Postgres.TemplateConverter.Parser as Parser - - --- | --- --- >>> convert "asdf ? \"'\\\"?'\" d 2??" --- Right "asdf $1 \"'\\\"?'\" d 2$2$3" -convert :: ByteString -> Either Text ByteString -convert t = - do - parts <- Parser.run t Parser.parts - return $ - BL.toStrict $ BB.toLazyByteString $ mconcat $ ($ 1) $ evalState $ do - forM parts $ \case - Parser.Chunk c -> do - return c - Parser.Placeholder -> do - i <- get - put $ succ i - return $ BB.char8 '$' <> BB.wordDec i - diff --git a/library/Hasql/Postgres/TemplateConverter/Parser.hs b/library/Hasql/Postgres/TemplateConverter/Parser.hs deleted file mode 100644 --- a/library/Hasql/Postgres/TemplateConverter/Parser.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Hasql.Postgres.TemplateConverter.Parser where - -import Hasql.Postgres.Prelude -import Data.Attoparsec.ByteString.Char8 -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Builder as BB - - -data Part = - Chunk BB.Builder | - Placeholder - -run :: ByteString -> Parser a -> Either Text a -run input parser = - either (Left . fromString) Right $ parseOnly (parser <* endOfInput) input - -parts :: Parser [Part] -parts = - many (chunk <|> placeholder) - where - chunk = - fmap Chunk $ fmap mconcat $ many1 $ stringLit <|> (BB.char8 <$> notChar '?') - placeholder = - char '?' *> pure Placeholder - -stringLit :: Parser BB.Builder -stringLit = - do - quote <- - char '"' <|> char '\'' - contentBuilders <- - many $ - (BB.byteString <$> string "\\\\") <|> - (BB.byteString <$> string (fromString ['\\', quote])) <|> - (BB.char8 <$> notChar quote) - char quote - return $ - BB.char7 quote <> mconcat contentBuilders <> BB.char7 quote -