diff --git a/hasql.cabal b/hasql.cabal --- a/hasql.cabal +++ b/hasql.cabal @@ -1,7 +1,7 @@ name: hasql version: - 0.19.8 + 0.19.9 category: Hasql, Database, PostgreSQL synopsis: @@ -76,6 +76,8 @@ -- database: postgresql-binary >= 0.8 && < 0.9, postgresql-libpq == 0.9.*, + -- builders: + bytestring-tree-builder >= 0.2.5 && < 0.3, -- data: dlist >= 0.7 && < 0.8, aeson >= 0.7 && < 0.12, @@ -88,6 +90,7 @@ bytestring >= 0.10 && < 0.11, hashable >= 1.2 && < 1.3, -- control: + semigroups >= 0.18 && < 0.20, data-default-class >= 0.0.1 && < 0.1, profunctors >= 5.1 && < 6, contravariant-extras == 0.3.*, @@ -129,24 +132,10 @@ tasty-hunit == 0.9.*, quickcheck-instances >= 0.3.11 && < 0.4, QuickCheck >= 2.8.1 && < 2.9, - -- data: - uuid, - time, - scientific, - bytestring, - text, - vector, - hashable, - dlist, -- general: data-default-class, - profunctors, - contravariant, - contravariant-extras, - either, - transformers, - base-prelude, - base + -- base, + rebase benchmark benchmark diff --git a/library/Hasql/Commands.hs b/library/Hasql/Commands.hs --- a/library/Hasql/Commands.hs +++ b/library/Hasql/Commands.hs @@ -18,6 +18,8 @@ Commands (DList BB.Builder) deriving (Monoid) +instance Semigroup Commands + asBytes :: Commands -> ByteString asBytes (Commands list) = BL.toStrict $ BB.toLazyByteString $ foldMap (<> BB.char7 ';') $ list diff --git a/library/Hasql/Encoders.hs b/library/Hasql/Encoders.hs --- a/library/Hasql/Encoders.hs +++ b/library/Hasql/Encoders.hs @@ -106,7 +106,7 @@ -- newtype Params a = Params (Params.Params a) - deriving (Contravariant, Divisible, Monoid) + deriving (Contravariant, Divisible, Monoid, Semigroup) -- | -- Encode no parameters. diff --git a/library/Hasql/Encoders/Params.hs b/library/Hasql/Encoders/Params.hs --- a/library/Hasql/Encoders/Params.hs +++ b/library/Hasql/Encoders/Params.hs @@ -13,6 +13,8 @@ Params (Op (DList (LibPQ.Oid, Bool -> Maybe ByteString)) a) deriving (Contravariant, Divisible, Monoid) +instance Semigroup (Params a) + run :: Params a -> a -> DList (LibPQ.Oid, Bool -> Maybe ByteString) run (Params (Op op)) params = {-# SCC "run" #-} diff --git a/library/Hasql/Prelude.hs b/library/Hasql/Prelude.hs --- a/library/Hasql/Prelude.hs +++ b/library/Hasql/Prelude.hs @@ -16,7 +16,7 @@ -- base-prelude ------------------------- -import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error) +import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error, (<>), First(..), Last(..)) -- transformers ------------------------- @@ -52,6 +52,10 @@ ------------------------- import Control.Monad.Trans.Either as Exports import Data.Either.Combinators as Exports + +-- semigroups +------------------------- +import Data.Semigroup as Exports -- hashable ------------------------- diff --git a/library/Hasql/Private/IO.hs b/library/Hasql/Private/IO.hs --- a/library/Hasql/Private/IO.hs +++ b/library/Hasql/Private/IO.hs @@ -75,25 +75,28 @@ IO (Either ResultsDecoders.Error ByteString) getPreparedStatementKey connection registry template oidList = {-# SCC "getPreparedStatementKey" #-} - do - keyMaybe <- PreparedStatementRegistry.lookup template wordOIDList registry - case keyMaybe of - Just key -> - pure (pure key) - Nothing -> - do - key <- PreparedStatementRegistry.register template wordOIDList registry - sent <- LibPQ.sendPrepare connection key template (mfilter (not . null) (Just oidList)) - let resultsDecoder = - if sent - then ResultsDecoders.single ResultDecoders.unit - else ResultsDecoders.clientError - runEitherT $ do - EitherT $ getResults connection undefined resultsDecoder - pure key + PreparedStatementRegistry.update localKey onNewRemoteKey onOldRemoteKey registry where - wordOIDList = - map (\(LibPQ.Oid x) -> fromIntegral x) oidList + localKey = + PreparedStatementRegistry.LocalKey template wordOIDList + where + wordOIDList = + map (\(LibPQ.Oid x) -> fromIntegral x) oidList + onNewRemoteKey key = + do + sent <- LibPQ.sendPrepare connection key template (mfilter (not . null) (Just oidList)) + let resultsDecoder = + if sent + then ResultsDecoders.single ResultDecoders.unit + else ResultsDecoders.clientError + fmap resultsMapping $ getResults connection undefined resultsDecoder + where + resultsMapping = + \case + Left x -> (False, Left x) + Right _ -> (True, Right key) + onOldRemoteKey key = + pure (pure key) {-# INLINE checkedSend #-} checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either ResultsDecoders.Error ()) diff --git a/library/Hasql/Private/PreparedStatementRegistry.hs b/library/Hasql/Private/PreparedStatementRegistry.hs --- a/library/Hasql/Private/PreparedStatementRegistry.hs +++ b/library/Hasql/Private/PreparedStatementRegistry.hs @@ -2,37 +2,47 @@ ( PreparedStatementRegistry, new, - lookup, - register, + update, + LocalKey(..), ) where import Hasql.Prelude hiding (lookup) -import qualified Data.HashTable.IO as Hashtables +import qualified Data.HashTable.IO as A +import qualified ByteString.TreeBuilder as B data PreparedStatementRegistry = - PreparedStatementRegistry !(Hashtables.BasicHashTable LocalKey ByteString) !(IORef Word) + PreparedStatementRegistry !(A.BasicHashTable LocalKey ByteString) !(IORef Word) {-# INLINABLE new #-} new :: IO PreparedStatementRegistry new = - PreparedStatementRegistry <$> Hashtables.new <*> newIORef 0 + PreparedStatementRegistry <$> A.new <*> newIORef 0 -{-# INLINABLE lookup #-} -lookup :: ByteString -> [Word32] -> PreparedStatementRegistry -> IO (Maybe ByteString) -lookup template oids (PreparedStatementRegistry table counter) = - Hashtables.lookup table (LocalKey template oids) +{-# INLINABLE update #-} +update :: LocalKey -> (ByteString -> IO (Bool, a)) -> (ByteString -> IO a) -> PreparedStatementRegistry -> IO a +update localKey onNewRemoteKey onOldRemoteKey (PreparedStatementRegistry table counter) = + lookup >>= maybe new old + where + lookup = + A.lookup table localKey + new = + readIORef counter >>= onN + where + onN n = + do + (save, result) <- onNewRemoteKey remoteKey + when save $ do + A.insert table localKey remoteKey + writeIORef counter (succ n) + return result + where + remoteKey = + B.toByteString . B.asciiIntegral $ n + old = + onOldRemoteKey -{-# INLINABLE register #-} -register :: ByteString -> [Word32] -> PreparedStatementRegistry -> IO ByteString -register template oids (PreparedStatementRegistry table counter) = - do - n <- readIORef counter - writeIORef counter (succ n) - let remoteKey = fromString (show n) - Hashtables.insert table (LocalKey template oids) remoteKey - return remoteKey -- | -- Local statement key. diff --git a/tasty/Main.hs b/tasty/Main.hs --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -22,6 +22,58 @@ localOption (NumThreads 1) $ testGroup "All tests" [ + testCase "Failing prepared statements" $ + let + io = + Connection.with (Session.run session) >>= + (assertBool <$> show <*> resultTest) + where + resultTest = + \case + Right (Left (Session.ResultError (Session.ServerError "26000" _ _ _))) -> False + _ -> True + session = + catchError session (const (pure ())) *> session + where + session = + Session.query () query + where + query = + Query.statement sql encoder decoder True + where + sql = + "absurd" + encoder = + Encoders.unit + decoder = + Decoders.unit + in io + , + testCase "Prepared statements after error" $ + let + io = + Connection.with (Session.run session) >>= + \x -> assertBool (show x) (either (const False) isRight x) + where + session = + try *> fail *> try + where + try = + Session.query 1 query + where + query = + Query.statement sql encoder decoder True + where + sql = + "select $1 :: int8" + encoder = + Encoders.value Encoders.int8 + decoder = + Decoders.singleRow $ Decoders.value Decoders.int8 + fail = + catchError (Session.sql "absurd") (const (pure ())) + in io + , testCase "\"in progress after error\" bugfix" $ let sumQuery :: Query.Query (Int64, Int64) Int64 diff --git a/tasty/Main/Prelude.hs b/tasty/Main/Prelude.hs --- a/tasty/Main/Prelude.hs +++ b/tasty/Main/Prelude.hs @@ -7,67 +7,8 @@ -- base-prelude ------------------------- -import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error) - --- 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, liftListen, liftPass) -import Data.Functor.Identity as Exports +import Rebase.Prelude as Exports -- data-default-class ------------------------- import Data.Default.Class as Exports - --- profunctors -------------------------- -import Data.Profunctor.Unsafe as Exports - --- contravariant -------------------------- -import Data.Functor.Contravariant as Exports -import Data.Functor.Contravariant.Divisible as Exports - --- contravariant-extras -------------------------- -import Contravariant.Extras as Exports - --- either -------------------------- -import Control.Monad.Trans.Either as Exports -import Data.Either.Combinators as Exports - --- hashable -------------------------- -import Data.Hashable as Exports (Hashable(..)) - --- text -------------------------- -import Data.Text as Exports (Text) - --- bytestring -------------------------- -import Data.ByteString as Exports (ByteString) - --- scientific -------------------------- -import Data.Scientific as Exports (Scientific) - --- uuid -------------------------- -import Data.UUID as Exports (UUID) - --- time -------------------------- -import Data.Time as Exports - --- vector -------------------------- -import Data.Vector as Exports (Vector) - --- dlist -------------------------- -import Data.DList as Exports (DList)