hasql 1.6.3.2 → 1.6.3.3
raw patch · 25 files changed
+648/−562 lines, 25 filesdep −QuickCheckdep ~basePVP ok
version bump matches the API change (PVP)
Dependencies removed: QuickCheck
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- README.md +2/−1
- benchmarks/Main.hs +1/−1
- hasql.cabal +2/−3
- library/Hasql/Connection.hs +1/−1
- library/Hasql/Private/Commands.hs +0/−1
- library/Hasql/Private/Decoders.hs +3/−5
- library/Hasql/Private/Decoders/Array.hs +1/−1
- library/Hasql/Private/Decoders/Result.hs +32/−28
- library/Hasql/Private/Decoders/Results.hs +14/−11
- library/Hasql/Private/Decoders/Row.hs +8/−7
- library/Hasql/Private/Encoders.hs +1/−1
- library/Hasql/Private/Encoders/Params.hs +3/−2
- library/Hasql/Private/Encoders/Value.hs +1/−1
- library/Hasql/Private/Errors.hs +8/−8
- library/Hasql/Private/IO.hs +0/−1
- library/Hasql/Private/PTI.hs +70/−0
- library/Hasql/Private/Prelude.hs +3/−3
- library/Hasql/Private/Session.hs +22/−20
- library/Hasql/Private/Settings.hs +21/−16
- profiling/Main.hs +2/−2
- tasty/Main.hs +434/−424
- tasty/Main/Connection.hs +1/−3
- tasty/Main/DSL.hs +4/−7
- tasty/Main/Statements.hs +9/−8
- threads-test/Main.hs +5/−7
README.md view
@@ -2,7 +2,8 @@ Hasql is a highly efficient PostgreSQL driver for Haskell with a typesafe yet flexible mapping API. It targets both the users, who need maximum control, and the users who face the typical tasks of DB-powered applications, providing them with higher-level APIs. Currently it is known to be [the fastest driver](https://nikita-volkov.github.io/hasql-benchmarks/) in the Haskell ecosystem. -Hasql also is one of the supported targets of the [pGenie](https://pgenie.io) code generator, which empowers it with schema and query validation, and relieves you from boilerplate.+> [!IMPORTANT]+> Hasql is one of the supported targets of the [pGenie](https://pgenie.io) code generator, which empowers it with schema and query validation, and relieves you from boilerplate. # Status
benchmarks/Main.hs view
@@ -25,7 +25,7 @@ sessionBench "manySmallResults" sessionWithManySmallResults ] where- sessionBench :: NFData a => String -> B.Session a -> Benchmark+ sessionBench :: (NFData a) => String -> B.Session a -> Benchmark sessionBench name session = bench name (nfIO (fmap (either (error "") id) (B.run session connection)))
hasql.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: hasql-version: 1.6.3.2+version: 1.6.3.3 category: Hasql, Database, PostgreSQL synopsis: An efficient PostgreSQL driver with a flexible mapping API description:@@ -99,7 +99,7 @@ build-depends: , aeson >=2 && <3 , attoparsec >=0.10 && <0.15- , base >=4.12 && <5+ , base >=4.13 && <5 , bytestring >=0.10 && <0.12 , bytestring-strict-builder >=0.4.5.1 && <0.5 , contravariant >=1.3 && <2@@ -172,7 +172,6 @@ build-depends: , contravariant-extras >=0.3.5.2 && <0.4 , hasql- , QuickCheck >=2.8.1 && <3 , quickcheck-instances >=0.3.11 && <0.4 , rerebase <2 , tasty >=0.12 && <2
library/Hasql/Connection.hs view
@@ -2,7 +2,7 @@ -- This module provides a low-level effectful API dealing with the connections to the database. module Hasql.Connection ( Connection,- ConnectionError (..),+ ConnectionError, acquire, release, Settings,
library/Hasql/Private/Commands.hs view
@@ -6,7 +6,6 @@ ) where -import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL import Hasql.Private.Prelude
library/Hasql/Private/Decoders.hs view
@@ -3,7 +3,6 @@ module Hasql.Private.Decoders where import qualified Data.Aeson as Aeson-import qualified Data.Vector as Vector import qualified Data.Vector.Generic as GenericVector import qualified Hasql.Private.Decoders.Array as Array import qualified Hasql.Private.Decoders.Composite as Composite@@ -11,7 +10,6 @@ import qualified Hasql.Private.Decoders.Results as Results import qualified Hasql.Private.Decoders.Row as Row import qualified Hasql.Private.Decoders.Value as Value-import qualified Hasql.Private.Errors as Errors import Hasql.Private.Prelude hiding (bool, maybe) import qualified Hasql.Private.Prelude as Prelude import qualified Network.IP.Addr as NetworkIp@@ -306,7 +304,7 @@ -- x = hstore 'replicateM' -- @ {-# INLINEABLE hstore #-}-hstore :: (forall m. Monad m => Int -> m (Text, Maybe Text) -> m a) -> Value a+hstore :: (forall m. (Monad m) => Int -> m (Text, Maybe Text) -> m a) -> Value a hstore replicateM = Value (Value.decoder (const (A.hstore replicateM A.text_strict A.text_strict))) -- |@@ -348,7 +346,7 @@ -- Please notice that in case of multidimensional arrays nesting 'vectorArray' decoder -- won't work. You have to explicitly construct the array decoder using 'array'. {-# INLINE vectorArray #-}-vectorArray :: GenericVector.Vector vector element => NullableOrNot Value element -> Value (vector element)+vectorArray :: (GenericVector.Vector vector element) => NullableOrNot Value element -> Value (vector element) vectorArray = array . dimension GenericVector.replicateM . element -- |@@ -383,7 +381,7 @@ -- -- * A decoder of its components, which can be either another 'dimension' or 'element'. {-# INLINEABLE dimension #-}-dimension :: (forall m. Monad m => Int -> m a -> m b) -> Array a -> Array b+dimension :: (forall m. (Monad m) => Int -> m a -> m b) -> Array a -> Array b dimension replicateM (Array imp) = Array (Array.dimension replicateM imp) -- |
library/Hasql/Private/Decoders/Array.hs view
@@ -13,7 +13,7 @@ A.array (runReaderT imp env) {-# INLINE dimension #-}-dimension :: (forall m. Monad m => Int -> m a -> m b) -> Array a -> Array b+dimension :: (forall m. (Monad m) => Int -> m a -> m b) -> Array a -> Array b dimension replicateM (Array imp) = Array $ ReaderT $ \env -> A.dimensionArray replicateM (runReaderT imp env)
library/Hasql/Private/Decoders/Result.hs view
@@ -34,10 +34,12 @@ checkExecStatus $ \case LibPQ.CommandOk -> True _ -> False- Result $- ReaderT $ \(_, result) ->- ExceptT $- LibPQ.cmdTuples result & fmap cmdTuplesReader+ Result+ $ ReaderT+ $ \(_, result) ->+ ExceptT+ $ LibPQ.cmdTuples result+ & fmap cmdTuplesReader where cmdTuplesReader = notNothing >=> notEmpty >=> decimal@@ -49,8 +51,8 @@ then Left (UnexpectedResult "Empty bytes") else Right bytes decimal bytes =- mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m)) $- Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes+ mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m))+ $ Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes {-# INLINE checkExecStatus #-} checkExecStatus :: (LibPQ.ExecStatus -> Bool) -> Result ()@@ -69,14 +71,15 @@ {-# INLINE serverError #-} serverError :: Result () serverError =- Result $- ReaderT $ \(_, result) -> ExceptT $ do+ Result+ $ ReaderT+ $ \(_, result) -> ExceptT $ do code <-- fmap fold $- LibPQ.resultErrorField result LibPQ.DiagSqlstate+ fmap fold+ $ LibPQ.resultErrorField result LibPQ.DiagSqlstate message <-- fmap fold $- LibPQ.resultErrorField result LibPQ.DiagMessagePrimary+ fmap fold+ $ LibPQ.resultErrorField result LibPQ.DiagMessagePrimary detail <- LibPQ.resultErrorField result LibPQ.DiagMessageDetail hint <-@@ -99,8 +102,9 @@ checkExecStatus $ \case LibPQ.TuplesOk -> True _ -> False- Result $- ReaderT $ \(integerDatetimes, result) -> ExceptT $ do+ Result+ $ ReaderT+ $ \(integerDatetimes, result) -> ExceptT $ do maxRows <- LibPQ.ntuples result case maxRows of 0 -> return (Right Nothing)@@ -112,8 +116,6 @@ where rowToInt (LibPQ.Row n) = fromIntegral n- intToRow =- LibPQ.Row . fromIntegral {-# INLINE single #-} single :: Row.Row a -> Result a@@ -122,8 +124,9 @@ checkExecStatus $ \case LibPQ.TuplesOk -> True _ -> False- Result $- ReaderT $ \(integerDatetimes, result) -> ExceptT $ do+ Result+ $ ReaderT+ $ \(integerDatetimes, result) -> ExceptT $ do maxRows <- LibPQ.ntuples result case maxRows of 1 -> do@@ -134,8 +137,6 @@ where rowToInt (LibPQ.Row n) = fromIntegral n- intToRow =- LibPQ.Row . fromIntegral {-# INLINE vector #-} vector :: Row.Row a -> Result (Vector a)@@ -144,8 +145,9 @@ checkExecStatus $ \case LibPQ.TuplesOk -> True _ -> False- Result $- ReaderT $ \(integerDatetimes, result) -> ExceptT $ do+ Result+ $ ReaderT+ $ \(integerDatetimes, result) -> ExceptT $ do maxRows <- LibPQ.ntuples result maxCols <- LibPQ.nfields result mvector <- MutableVector.unsafeNew (rowToInt maxRows)@@ -172,10 +174,11 @@ checkExecStatus $ \case LibPQ.TuplesOk -> True _ -> False- Result $- ReaderT $ \(integerDatetimes, result) ->- ExceptT $- {-# SCC "traversal" #-}+ Result+ $ ReaderT+ $ \(integerDatetimes, result) ->+ ExceptT+ $ {-# SCC "traversal" #-} do maxRows <- LibPQ.ntuples result maxCols <- LibPQ.nfields result@@ -203,8 +206,9 @@ checkExecStatus $ \case LibPQ.TuplesOk -> True _ -> False- Result $- ReaderT $ \(integerDatetimes, result) -> ExceptT $ do+ Result+ $ ReaderT+ $ \(integerDatetimes, result) -> ExceptT $ do maxRows <- LibPQ.ntuples result maxCols <- LibPQ.nfields result accRef <- newIORef init
library/Hasql/Private/Decoders/Results.hs view
@@ -12,7 +12,6 @@ import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Hasql.Private.Decoders.Result as Result-import qualified Hasql.Private.Decoders.Row as Row import Hasql.Private.Errors import Hasql.Private.Prelude hiding (many, maybe) import qualified Hasql.Private.Prelude as Prelude@@ -29,18 +28,20 @@ {-# INLINE clientError #-} clientError :: Results a clientError =- Results $- ReaderT $ \(_, connection) ->- ExceptT $- fmap (Left . ClientError) (LibPQ.errorMessage connection)+ Results+ $ ReaderT+ $ \(_, connection) ->+ ExceptT+ $ fmap (Left . ClientError) (LibPQ.errorMessage connection) -- | -- Parse a single result. {-# INLINE single #-} single :: Result.Result a -> Results a single resultDec =- Results $- ReaderT $ \(integerDatetimes, connection) -> ExceptT $ do+ Results+ $ ReaderT+ $ \(integerDatetimes, connection) -> ExceptT $ do resultMaybe <- LibPQ.getResult connection case resultMaybe of Just result ->@@ -53,8 +54,9 @@ {-# INLINE getResult #-} getResult :: Results LibPQ.Result getResult =- Results $- ReaderT $ \(_, connection) -> ExceptT $ do+ Results+ $ ReaderT+ $ \(_, connection) -> ExceptT $ do resultMaybe <- LibPQ.getResult connection case resultMaybe of Just result -> pure (Right result)@@ -85,7 +87,8 @@ ExceptT $ fmap (mapLeft ResultError) $ Result.run Result.noResult (integerDatetimes, result) refine :: (a -> Either Text b) -> Results a -> Results b-refine refiner results = Results $- ReaderT $ \env -> ExceptT $ do+refine refiner results = Results+ $ ReaderT+ $ \env -> ExceptT $ do resultEither <- run results env return $ resultEither >>= mapLeft (ResultError . UnexpectedResult) . refiner
library/Hasql/Private/Decoders/Row.hs view
@@ -41,21 +41,22 @@ value :: Value.Value a -> Row (Maybe a) value valueDec = {-# SCC "value" #-}- Row $- ReaderT $ \(Env result row columnsAmount integerDatetimes columnRef) -> ExceptT $ do+ Row+ $ ReaderT+ $ \(Env result row columnsAmount integerDatetimes columnRef) -> ExceptT $ do col <- readIORef columnRef writeIORef columnRef (succ col) if col < columnsAmount then do valueMaybe <- {-# SCC "getvalue'" #-} LibPQ.getvalue' result row col- pure $- case valueMaybe of+ pure+ $ case valueMaybe of Nothing -> Right Nothing Just value ->- fmap Just $- mapLeft ValueError $- {-# SCC "decode" #-} A.valueParser (Value.run valueDec integerDatetimes) value+ fmap Just+ $ mapLeft ValueError+ $ {-# SCC "decode" #-} A.valueParser (Value.run valueDec integerDatetimes) value else pure (Left EndOfInput) -- |
library/Hasql/Private/Encoders.hs view
@@ -330,7 +330,7 @@ -- Please notice that in case of multidimensional arrays nesting 'foldableArray' encoder -- won't work. You have to explicitly construct the array encoder using 'array'. {-# INLINE foldableArray #-}-foldableArray :: Foldable foldable => NullableOrNot Value element -> Value (foldable element)+foldableArray :: (Foldable foldable) => NullableOrNot Value element -> Value (foldable element) foldableArray = array . dimension foldl' . element -- * Array
library/Hasql/Private/Encoders/Params.hs view
@@ -19,8 +19,9 @@ nullableValue :: C.Value a -> Params (Maybe a) nullableValue (C.Value valueOID arrayOID encode render) =- Params $- Op $ \input ->+ Params+ $ Op+ $ \input -> let D.OID _ pqOid format = valueOID encoder env =
library/Hasql/Private/Encoders/Value.hs view
@@ -19,6 +19,6 @@ Value (PTI.ptiOID pti) (fromMaybe (error "No array OID") (PTI.ptiArrayOID pti)) {-# INLINE unsafePTIWithShow #-}-unsafePTIWithShow :: Show a => PTI.PTI -> (Bool -> a -> B.Encoding) -> Value a+unsafePTIWithShow :: (Show a) => PTI.PTI -> (Bool -> a -> B.Encoding) -> Value a unsafePTIWithShow pti encode = unsafePTI pti encode (C.string . show)
library/Hasql/Private/Errors.hs view
@@ -39,24 +39,24 @@ data ResultError = -- | An error reported by the DB. ServerError- ByteString- -- ^ __Code__. The SQLSTATE code for the error. It's recommended to use+ -- | __Code__. The SQLSTATE code for the error. It's recommended to use -- <http://hackage.haskell.org/package/postgresql-error-codes -- the "postgresql-error-codes" package> to work with those. ByteString- -- ^ __Message__. The primary human-readable error message(typically one+ -- | __Message__. The primary human-readable error message(typically one -- line). Always present.- (Maybe ByteString)- -- ^ __Details__. An optional secondary error message carrying more+ ByteString+ -- | __Details__. An optional secondary error message carrying more -- detail about the problem. Might run to multiple lines. (Maybe ByteString)- -- ^ __Hint__. An optional suggestion on what to do about the problem.+ -- | __Hint__. An optional suggestion on 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.- (Maybe Int)- -- ^ __Position__. Error cursor position as an index into the original+ (Maybe ByteString)+ -- | __Position__. Error cursor position as an index into the original -- statement string. Positions are measured in characters not bytes.+ (Maybe Int) | -- | -- The database returned an unexpected result. -- Indicates an improper statement or a schema mismatch.
library/Hasql/Private/IO.hs view
@@ -2,7 +2,6 @@ -- An API of low-level IO operations. module Hasql.Private.IO where -import qualified Data.DList as DList import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Hasql.Private.Commands as Commands import qualified Hasql.Private.Decoders.Result as ResultDecoders
library/Hasql/Private/PTI.hs view
@@ -19,142 +19,212 @@ -- * Constants +abstime :: PTI abstime = mkPTI LibPQ.Binary 702 (Just 1023) +aclitem :: PTI aclitem = mkPTI LibPQ.Binary 1033 (Just 1034) +bit :: PTI bit = mkPTI LibPQ.Binary 1560 (Just 1561) +bool :: PTI bool = mkPTI LibPQ.Binary 16 (Just 1000) +box :: PTI box = mkPTI LibPQ.Binary 603 (Just 1020) +bpchar :: PTI bpchar = mkPTI LibPQ.Binary 1042 (Just 1014) +bytea :: PTI bytea = mkPTI LibPQ.Binary 17 (Just 1001) +char :: PTI char = mkPTI LibPQ.Binary 18 (Just 1002) +cid :: PTI cid = mkPTI LibPQ.Binary 29 (Just 1012) +cidr :: PTI cidr = mkPTI LibPQ.Binary 650 (Just 651) +circle :: PTI circle = mkPTI LibPQ.Binary 718 (Just 719) +cstring :: PTI cstring = mkPTI LibPQ.Binary 2275 (Just 1263) +date :: PTI date = mkPTI LibPQ.Binary 1082 (Just 1182) +daterange :: PTI daterange = mkPTI LibPQ.Binary 3912 (Just 3913) +float4 :: PTI float4 = mkPTI LibPQ.Binary 700 (Just 1021) +float8 :: PTI float8 = mkPTI LibPQ.Binary 701 (Just 1022) +gtsvector :: PTI gtsvector = mkPTI LibPQ.Binary 3642 (Just 3644) +inet :: PTI inet = mkPTI LibPQ.Binary 869 (Just 1041) +int2 :: PTI int2 = mkPTI LibPQ.Binary 21 (Just 1005) +int2vector :: PTI int2vector = mkPTI LibPQ.Binary 22 (Just 1006) +int4 :: PTI int4 = mkPTI LibPQ.Binary 23 (Just 1007) +int4range :: PTI int4range = mkPTI LibPQ.Binary 3904 (Just 3905) +int8 :: PTI int8 = mkPTI LibPQ.Binary 20 (Just 1016) +int8range :: PTI int8range = mkPTI LibPQ.Binary 3926 (Just 3927) +interval :: PTI interval = mkPTI LibPQ.Binary 1186 (Just 1187) +json :: PTI json = mkPTI LibPQ.Binary 114 (Just 199) +jsonb :: PTI jsonb = mkPTI LibPQ.Binary 3802 (Just 3807) +line :: PTI line = mkPTI LibPQ.Binary 628 (Just 629) +lseg :: PTI lseg = mkPTI LibPQ.Binary 601 (Just 1018) +macaddr :: PTI macaddr = mkPTI LibPQ.Binary 829 (Just 1040) +money :: PTI money = mkPTI LibPQ.Binary 790 (Just 791) +name :: PTI name = mkPTI LibPQ.Binary 19 (Just 1003) +numeric :: PTI numeric = mkPTI LibPQ.Binary 1700 (Just 1231) +numrange :: PTI numrange = mkPTI LibPQ.Binary 3906 (Just 3907) +oid :: PTI oid = mkPTI LibPQ.Binary 26 (Just 1028) +oidvector :: PTI oidvector = mkPTI LibPQ.Binary 30 (Just 1013) +path :: PTI path = mkPTI LibPQ.Binary 602 (Just 1019) +point :: PTI point = mkPTI LibPQ.Binary 600 (Just 1017) +polygon :: PTI polygon = mkPTI LibPQ.Binary 604 (Just 1027) +record :: PTI record = mkPTI LibPQ.Binary 2249 (Just 2287) +refcursor :: PTI refcursor = mkPTI LibPQ.Binary 1790 (Just 2201) +regclass :: PTI regclass = mkPTI LibPQ.Binary 2205 (Just 2210) +regconfig :: PTI regconfig = mkPTI LibPQ.Binary 3734 (Just 3735) +regdictionary :: PTI regdictionary = mkPTI LibPQ.Binary 3769 (Just 3770) +regoper :: PTI regoper = mkPTI LibPQ.Binary 2203 (Just 2208) +regoperator :: PTI regoperator = mkPTI LibPQ.Binary 2204 (Just 2209) +regproc :: PTI regproc = mkPTI LibPQ.Binary 24 (Just 1008) +regprocedure :: PTI regprocedure = mkPTI LibPQ.Binary 2202 (Just 2207) +regtype :: PTI regtype = mkPTI LibPQ.Binary 2206 (Just 2211) +reltime :: PTI reltime = mkPTI LibPQ.Binary 703 (Just 1024) +text :: PTI text = mkPTI LibPQ.Binary 25 (Just 1009) +tid :: PTI tid = mkPTI LibPQ.Binary 27 (Just 1010) +time :: PTI time = mkPTI LibPQ.Binary 1083 (Just 1183) +timestamp :: PTI timestamp = mkPTI LibPQ.Binary 1114 (Just 1115) +timestamptz :: PTI timestamptz = mkPTI LibPQ.Binary 1184 (Just 1185) +timetz :: PTI timetz = mkPTI LibPQ.Binary 1266 (Just 1270) +tinterval :: PTI tinterval = mkPTI LibPQ.Binary 704 (Just 1025) +tsquery :: PTI tsquery = mkPTI LibPQ.Binary 3615 (Just 3645) +tsrange :: PTI tsrange = mkPTI LibPQ.Binary 3908 (Just 3909) +tstzrange :: PTI tstzrange = mkPTI LibPQ.Binary 3910 (Just 3911) +tsvector :: PTI tsvector = mkPTI LibPQ.Binary 3614 (Just 3643) +txid_snapshot :: PTI txid_snapshot = mkPTI LibPQ.Binary 2970 (Just 2949) +textUnknown :: PTI textUnknown = mkPTI LibPQ.Text 705 (Just 705) +binaryUnknown :: PTI binaryUnknown = mkPTI LibPQ.Binary 705 (Just 705) +uuid :: PTI uuid = mkPTI LibPQ.Binary 2950 (Just 2951) +varbit :: PTI varbit = mkPTI LibPQ.Binary 1562 (Just 1563) +varchar :: PTI varchar = mkPTI LibPQ.Binary 1043 (Just 1015) +void :: PTI void = mkPTI LibPQ.Binary 2278 Nothing +xid :: PTI xid = mkPTI LibPQ.Binary 28 (Just 1011) +xml :: PTI xml = mkPTI LibPQ.Binary 142 (Just 143)
library/Hasql/Private/Prelude.hs view
@@ -46,7 +46,7 @@ import Data.Fixed as Exports import Data.Foldable as Exports hiding (toList) import Data.Function as Exports hiding (id, (.))-import Data.Functor as Exports+import Data.Functor as Exports hiding (unzip) import Data.Functor.Compose as Exports import Data.Functor.Contravariant as Exports import Data.Functor.Contravariant.Divisible as Exports@@ -117,12 +117,12 @@ Data.Text.Lazy.Builder.Builder {-# INLINE forMToZero_ #-}-forMToZero_ :: Applicative m => Int -> (Int -> m a) -> m ()+forMToZero_ :: (Applicative m) => Int -> (Int -> m a) -> m () forMToZero_ !startN f = ($ pred startN) $ fix $ \loop !n -> if n >= 0 then f n *> loop (pred n) else pure () {-# INLINE forMFromZero_ #-}-forMFromZero_ :: Applicative m => Int -> (Int -> m a) -> m ()+forMFromZero_ :: (Applicative m) => Int -> (Int -> m a) -> m () forMFromZero_ !endN f = ($ 0) $ fix $ \loop !n -> if n < endN then f n *> loop (succ n) else pure ()
library/Hasql/Private/Session.hs view
@@ -1,6 +1,5 @@ module Hasql.Private.Session where -import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Hasql.Private.Connection as Connection import qualified Hasql.Private.Decoders.Result as Decoders.Result import qualified Hasql.Private.Decoders.Results as Decoders.Results@@ -9,7 +8,6 @@ import Hasql.Private.Errors import qualified Hasql.Private.IO as IO import Hasql.Private.Prelude-import qualified Hasql.Private.Settings as Settings import qualified Hasql.Statement as Statement -- |@@ -22,8 +20,8 @@ -- Executes a bunch of commands on the provided connection. run :: Session a -> Connection.Connection -> IO (Either QueryError a) run (Session impl) connection =- runExceptT $- runReaderT impl connection+ runExceptT+ $ runReaderT impl connection -- | -- Possibly a multi-statement query,@@ -31,14 +29,16 @@ -- nor can any results of it be collected. sql :: ByteString -> Session () sql sql =- Session $- ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) ->- ExceptT $- fmap (mapLeft (QueryError sql [])) $- withMVar pqConnectionRef $ \pqConnection -> do- r1 <- IO.sendNonparametricStatement pqConnection sql- r2 <- IO.getResults pqConnection integerDatetimes decoder- return $ r1 *> r2+ Session+ $ ReaderT+ $ \(Connection.Connection pqConnectionRef integerDatetimes registry) ->+ ExceptT+ $ fmap (mapLeft (QueryError sql []))+ $ withMVar pqConnectionRef+ $ \pqConnection -> do+ r1 <- IO.sendNonparametricStatement pqConnection sql+ r2 <- IO.getResults pqConnection integerDatetimes decoder+ return $ r1 *> r2 where decoder = Decoders.Results.single Decoders.Result.noResult@@ -47,14 +47,16 @@ -- Parameters and a specification of a parametric single-statement query to apply them to. statement :: params -> Statement.Statement params result -> Session result statement input (Statement.Statement template (Encoders.Params paramsEncoder) decoder preparable) =- Session $- ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) ->- ExceptT $- fmap (mapLeft (QueryError template inputReps)) $- withMVar pqConnectionRef $ \pqConnection -> do- r1 <- IO.sendParametricStatement pqConnection integerDatetimes registry template paramsEncoder preparable input- r2 <- IO.getResults pqConnection integerDatetimes (unsafeCoerce decoder)- return $ r1 *> r2+ Session+ $ ReaderT+ $ \(Connection.Connection pqConnectionRef integerDatetimes registry) ->+ ExceptT+ $ fmap (mapLeft (QueryError template inputReps))+ $ withMVar pqConnectionRef+ $ \pqConnection -> do+ r1 <- IO.sendParametricStatement pqConnection integerDatetimes registry template paramsEncoder preparable input+ r2 <- IO.getResults pqConnection integerDatetimes (unsafeCoerce decoder)+ return $ r1 *> r2 where inputReps = let Encoders.Params.Params (Op encoderOp) = paramsEncoder
library/Hasql/Private/Settings.hs view
@@ -16,19 +16,24 @@ {-# INLINE settings #-} settings :: ByteString -> Word16 -> ByteString -> ByteString -> ByteString -> Settings settings host port user password database =- BL.toStrict $- BB.toLazyByteString $- mconcat $- intersperse (BB.char7 ' ') $- catMaybes $- [ mappend (BB.string7 "host=") . BB.byteString- <$> mfilter (not . B.null) (pure host),- mappend (BB.string7 "port=") . BB.word16Dec- <$> mfilter (/= 0) (pure port),- mappend (BB.string7 "user=") . BB.byteString- <$> mfilter (not . B.null) (pure user),- mappend (BB.string7 "password=") . BB.byteString- <$> mfilter (not . B.null) (pure password),- mappend (BB.string7 "dbname=") . BB.byteString- <$> mfilter (not . B.null) (pure database)- ]+ BL.toStrict+ $ BB.toLazyByteString+ $ mconcat+ $ intersperse (BB.char7 ' ')+ $ catMaybes+ $ [ mappend (BB.string7 "host=")+ . BB.byteString+ <$> mfilter (not . B.null) (pure host),+ mappend (BB.string7 "port=")+ . BB.word16Dec+ <$> mfilter (/= 0) (pure port),+ mappend (BB.string7 "user=")+ . BB.byteString+ <$> mfilter (not . B.null) (pure user),+ mappend (BB.string7 "password=")+ . BB.byteString+ <$> mfilter (not . B.null) (pure password),+ mappend (BB.string7 "dbname=")+ . BB.byteString+ <$> mfilter (not . B.null) (pure database)+ ]
profiling/Main.hs view
@@ -3,11 +3,11 @@ import qualified Data.Vector as F import qualified Hasql.Connection as A import qualified Hasql.Decoders as D-import qualified Hasql.Encoders as E import qualified Hasql.Session as B import qualified Hasql.Statement as C import Prelude +main :: IO () main = do Right connection <- acquireConnection@@ -25,7 +25,7 @@ host = "localhost" port = 5432 user = "postgres"- password = ""+ password = "postgres" database = "postgres" -- * Sessions
tasty/Main.hs view
@@ -9,388 +9,134 @@ import qualified Main.DSL as DSL import Main.Prelude hiding (assert) import qualified Main.Statements as Statements-import qualified Test.QuickCheck as QuickCheck-import Test.QuickCheck.Instances+import Test.QuickCheck.Instances () import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Test.Tasty.Runners +main :: IO () main = defaultMain tree +tree :: TestTree tree =- localOption (NumThreads 1) $- testGroup+ localOption (NumThreads 1)+ $ testGroup "All tests"- [ testGroup "Roundtrips" $- let roundtrip encoder decoder input =- let session =- let statement = Statement.Statement "select $1" encoder decoder True- in Session.statement input statement- in unsafePerformIO $ do- x <- Connection.with (Session.run session)- return (Right (Right input) === x)- in [ testProperty "Array" $- let encoder = Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))- decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.array (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8))))))- in roundtrip encoder decoder,- testProperty "2D Array" $- let encoder = Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))))- decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.array (Decoders.dimension replicateM (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8)))))))- in \list -> list /= [] ==> roundtrip encoder decoder (replicate 3 list)- ],- testCase "Failed query" $- let statement =- Statement.Statement "select true where 1 = any ($1) and $2" encoder decoder True- where- encoder =- contrazip2- (Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))))- (Encoders.param (Encoders.nonNullable (Encoders.text)))- decoder =- fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool))- session =- Session.statement ([3, 7], "a") statement- in do- x <- Connection.with (Session.run session)- assertBool (show x) $ case x of- Right (Left (Session.QueryError "select true where 1 = any ($1) and $2" ["[3, 7]", "\"a\""] _)) -> True- _ -> False,- testCase "IN simulation" $- let statement =- Statement.Statement "select true where 1 = any ($1)" encoder decoder True- where- encoder =- Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))- decoder =- fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool))- session =- do- result1 <- Session.statement [1, 2] statement- result2 <- Session.statement [2, 3] statement- return (result1, result2)- in do- x <- Connection.with (Session.run session)- assertEqual (show x) (Right (Right (True, False))) x,- testCase "NOT IN simulation" $- let statement =- Statement.Statement "select true where 3 <> all ($1)" encoder decoder True- where- encoder =- Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))- decoder =- fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool))- session =- do- result1 <- Session.statement [1, 2] statement- result2 <- Session.statement [2, 3] statement- return (result1, result2)- in do- x <- Connection.with (Session.run session)- assertEqual (show x) (Right (Right (True, False))) x,- testCase "Composite decoding" $- let statement =- Statement.Statement sql encoder decoder True- where- sql =- "select (1, true)"- encoder =- mempty- decoder =- Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.composite ((,) <$> (Decoders.field . Decoders.nonNullable) Decoders.int8 <*> (Decoders.field . Decoders.nonNullable) Decoders.bool)))- session =- Session.statement () statement- in do- x <- Connection.with (Session.run session)- assertEqual (show x) (Right (Right (1, True))) x,- testCase "Complex composite decoding" $- let statement =- Statement.Statement sql encoder decoder True- where- sql =- "select (1, true) as entity1, ('hello', 3) as entity2"- encoder =- mempty- decoder =- Decoders.singleRow $- (,) <$> (Decoders.column . Decoders.nonNullable) entity1 <*> (Decoders.column . Decoders.nonNullable) entity2- where- entity1 =- Decoders.composite $- (,) <$> (Decoders.field . Decoders.nonNullable) Decoders.int8 <*> (Decoders.field . Decoders.nonNullable) Decoders.bool- entity2 =- Decoders.composite $- (,) <$> (Decoders.field . Decoders.nonNullable) Decoders.text <*> (Decoders.field . Decoders.nonNullable) Decoders.int8- session =- Session.statement () statement- in do- x <- Connection.with (Session.run session)- assertEqual (show x) (Right (Right ((1, True), ("hello", 3)))) x,- testGroup "unknownEnum" $- [ testCase "" $ do- res <- DSL.session $ do- let statement =- Statement.Statement sql mempty Decoders.noResult True- where- sql =- "drop type if exists mood"- in DSL.statement () statement- let statement =- Statement.Statement sql mempty Decoders.noResult True- where- sql =- "create type mood as enum ('sad', 'ok', 'happy')"- in DSL.statement () statement- let statement =- Statement.Statement sql encoder decoder True- where- sql =- "select $1"- decoder =- (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.enum (Just . id))))- encoder =- Encoders.param (Encoders.nonNullable (Encoders.unknownEnum id))- in DSL.statement "ok" statement-- assertEqual "" (Right "ok") res- ],- testCase "Composite encoding" $ do- let value =- (123, 456, 789, "abc")- res <-- let statement =+ [ testGroup "Roundtrips"+ $ let roundtrip encoder decoder input =+ let session =+ let statement = Statement.Statement "select $1" encoder decoder True+ in Session.statement input statement+ in unsafePerformIO $ do+ x <- Connection.with (Session.run session)+ return (Right (Right input) === x)+ in [ testProperty "Array"+ $ let encoder = Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))+ decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.array (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8))))))+ in roundtrip encoder decoder,+ testProperty "2D Array"+ $ let encoder = Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))))+ decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.array (Decoders.dimension replicateM (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8)))))))+ in \list -> list /= [] ==> roundtrip encoder decoder (replicate 3 list)+ ],+ testCase "Failed query"+ $ let statement =+ Statement.Statement "select true where 1 = any ($1) and $2" encoder decoder True+ where+ encoder =+ contrazip2+ (Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))))+ (Encoders.param (Encoders.nonNullable (Encoders.text)))+ decoder =+ fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool))+ session =+ Session.statement ([3, 7], "a") statement+ in do+ x <- Connection.with (Session.run session)+ assertBool (show x) $ case x of+ Right (Left (Session.QueryError "select true where 1 = any ($1) and $2" ["[3, 7]", "\"a\""] _)) -> True+ _ -> False,+ testCase "IN simulation"+ $ let statement =+ Statement.Statement "select true where 1 = any ($1)" encoder decoder True+ where+ encoder =+ Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))+ decoder =+ fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool))+ session =+ do+ result1 <- Session.statement [1, 2] statement+ result2 <- Session.statement [2, 3] statement+ return (result1, result2)+ in do+ x <- Connection.with (Session.run session)+ assertEqual (show x) (Right (Right (True, False))) x,+ testCase "NOT IN simulation"+ $ let statement =+ Statement.Statement "select true where 3 <> all ($1)" encoder decoder True+ where+ encoder =+ Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))+ decoder =+ fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool))+ session =+ do+ result1 <- Session.statement [1, 2] statement+ result2 <- Session.statement [2, 3] statement+ return (result1, result2)+ in do+ x <- Connection.with (Session.run session)+ assertEqual (show x) (Right (Right (True, False))) x,+ testCase "Composite decoding"+ $ let statement = Statement.Statement sql encoder decoder True where sql =- "select $1 :: pg_enum"+ "select (1, true)" encoder =- Encoders.param . Encoders.nonNullable . Encoders.composite . mconcat $- [ contramap (\(a, _, _, _) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.oid,- contramap (\(_, a, _, _) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.oid,- contramap (\(_, _, a, _) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.float4,- contramap (\(_, _, _, a) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.name- ]+ mempty decoder =- Decoders.singleRow $- (Decoders.column . Decoders.nonNullable . Decoders.composite)- ( (,,,)- <$> (Decoders.field . Decoders.nonNullable) Decoders.int4- <*> (Decoders.field . Decoders.nonNullable) Decoders.int4- <*> (Decoders.field . Decoders.nonNullable) Decoders.float4- <*> (Decoders.field . Decoders.nonNullable) Decoders.text- )- in Connection.with $ Session.run $ Session.statement value statement- assertEqual "" (Right (Right value)) res,- testCase "Empty array" $- let io =- do+ Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.composite ((,) <$> (Decoders.field . Decoders.nonNullable) Decoders.int8 <*> (Decoders.field . Decoders.nonNullable) Decoders.bool)))+ session =+ Session.statement () statement+ in do x <- Connection.with (Session.run session)- assertEqual (show x) (Right (Right [])) x- where- session =- Session.statement () statement- where- statement =- Statement.Statement sql encoder decoder True- where- sql =- "select array[]::int8[]"- encoder =- mempty- decoder =- Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.array (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8)))))- in io,- testCase "Failing prepared statements" $- let io =- Connection.with (Session.run session)- >>= (assertBool <$> show <*> resultTest)- where- resultTest =- \case- Right (Left (Session.QueryError _ _ (Session.ResultError (Session.ServerError "26000" _ _ _ _)))) -> False- _ -> True- session =- catchError session (const (pure ())) *> session- where- session =- Session.statement () statement- where- statement =- Statement.Statement sql encoder decoder True- where- sql =- "absurd"- encoder =- mempty- decoder =- Decoders.noResult- 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.statement 1 statement- where- statement =- Statement.Statement sql encoder decoder True- where- sql =- "select $1 :: int8"- encoder =- Encoders.param (Encoders.nonNullable (Encoders.int8))- decoder =- Decoders.singleRow $ (Decoders.column . Decoders.nonNullable) Decoders.int8- fail =- catchError (Session.sql "absurd") (const (pure ()))- in io,- testCase "\"in progress after error\" bugfix" $- let sumStatement :: Statement.Statement (Int64, Int64) Int64- sumStatement =- Statement.Statement sql encoder decoder True- where- sql =- "select ($1 + $2)"- encoder =- contramap fst (Encoders.param (Encoders.nonNullable (Encoders.int8)))- <> contramap snd (Encoders.param (Encoders.nonNullable (Encoders.int8)))- decoder =- Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8)- sumSession :: Session.Session Int64- sumSession =- Session.sql "begin" *> Session.statement (1, 1) sumStatement <* Session.sql "end"- errorSession :: Session.Session ()- errorSession =- Session.sql "asldfjsldk"- io =- Connection.with $ \c -> do- Session.run errorSession c- Session.run sumSession c- in io >>= \x -> assertBool (show x) (either (const False) isRight x),- testCase "\"another command is already in progress\" bugfix" $- let sumStatement :: Statement.Statement (Int64, Int64) Int64- sumStatement =- Statement.Statement sql encoder decoder True- where- sql =- "select ($1 + $2)"- encoder =- contramap fst (Encoders.param (Encoders.nonNullable (Encoders.int8)))- <> contramap snd (Encoders.param (Encoders.nonNullable (Encoders.int8)))- decoder =- Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8)- session :: Session.Session Int64- session =- do- Session.sql "begin;"- s <- Session.statement (1, 1) sumStatement- Session.sql "end;"- return s- in DSL.session session >>= \x -> assertEqual (show x) (Right 2) x,- testCase "Executing the same query twice" $- pure (),- testCase "Interval Encoding" $- let actualIO =- DSL.session $ do- let statement =- Statement.Statement sql encoder decoder True- where- sql =- "select $1 = interval '10 seconds'"- decoder =- (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool)))- encoder =- Encoders.param (Encoders.nonNullable (Encoders.interval))- in DSL.statement (10 :: DiffTime) statement- in actualIO >>= \x -> assertEqual (show x) (Right True) x,- testCase "Interval Decoding" $- let actualIO =- DSL.session $ do- let statement =- Statement.Statement sql encoder decoder True- where- sql =- "select interval '10 seconds'"- decoder =- (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval)))- encoder =- Encoders.noParams- in DSL.statement () statement- in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x,- testCase "Interval Encoding/Decoding" $- let actualIO =- DSL.session $ do- let statement =- Statement.Statement sql encoder decoder True- where- sql =- "select $1"- decoder =- (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval)))- encoder =- Encoders.param (Encoders.nonNullable (Encoders.interval))- in DSL.statement (10 :: DiffTime) statement- in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x,- testCase "Unknown" $- let actualIO =- DSL.session $ do- let statement =- Statement.Statement sql mempty Decoders.noResult True- where- sql =- "drop type if exists mood"- in DSL.statement () statement- let statement =- Statement.Statement sql mempty Decoders.noResult True- where- sql =- "create type mood as enum ('sad', 'ok', 'happy')"- in DSL.statement () statement- let statement =- Statement.Statement sql encoder decoder True- where- sql =- "select $1 = ('ok' :: mood)"- decoder =- (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool)))- encoder =- Encoders.param (Encoders.nonNullable (Encoders.unknown))- in DSL.statement "ok" statement- in actualIO >>= assertEqual "" (Right True),- testCase "Textual Unknown" $- let actualIO =- DSL.session $ do- let statement =- Statement.Statement sql mempty Decoders.noResult True- where- sql =- "create or replace function overloaded(a int, b int) returns int as $$ select a + b $$ language sql;"- in DSL.statement () statement- let statement =- Statement.Statement sql mempty Decoders.noResult True- where- sql =- "create or replace function overloaded(a text, b text, c text) returns text as $$ select a || b || c $$ language sql;"- in DSL.statement () statement- let statement =- Statement.Statement sql encoder decoder True- where- sql =- "select overloaded($1, $2) || overloaded($3, $4, $5)"- decoder =- (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text)))- encoder =- contramany (Encoders.param (Encoders.nonNullable (Encoders.unknown)))- in DSL.statement ["1", "2", "4", "5", "6"] statement- in actualIO >>= assertEqual "" (Right "3456"),- testCase "Enum" $- let actualIO =- DSL.session $ do+ assertEqual (show x) (Right (Right (1, True))) x,+ testCase "Complex composite decoding"+ $ let statement =+ Statement.Statement sql encoder decoder True+ where+ sql =+ "select (1, true) as entity1, ('hello', 3) as entity2"+ encoder =+ mempty+ decoder =+ Decoders.singleRow+ $ (,)+ <$> (Decoders.column . Decoders.nonNullable) entity1+ <*> (Decoders.column . Decoders.nonNullable) entity2+ where+ entity1 =+ Decoders.composite+ $ (,)+ <$> (Decoders.field . Decoders.nonNullable) Decoders.int8+ <*> (Decoders.field . Decoders.nonNullable) Decoders.bool+ entity2 =+ Decoders.composite+ $ (,)+ <$> (Decoders.field . Decoders.nonNullable) Decoders.text+ <*> (Decoders.field . Decoders.nonNullable) Decoders.int8+ session =+ Session.statement () statement+ in do+ x <- Connection.with (Session.run session)+ assertEqual (show x) (Right (Right ((1, True), ("hello", 3)))) x,+ testGroup "unknownEnum"+ $ [ testCase "" $ do+ res <- DSL.session $ do let statement = Statement.Statement sql mempty Decoders.noResult True where@@ -407,63 +153,327 @@ Statement.Statement sql encoder decoder True where sql =- "select ($1 :: mood)"+ "select $1" decoder = (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.enum (Just . id)))) encoder =- Encoders.param (Encoders.nonNullable ((Encoders.enum id)))+ Encoders.param (Encoders.nonNullable (Encoders.unknownEnum id)) in DSL.statement "ok" statement- in actualIO >>= assertEqual "" (Right "ok"),- testCase "The same prepared statement used on different types" $- let actualIO =- DSL.session $ do- let effect1 =- DSL.statement "ok" statement- where- statement =- Statement.Statement sql encoder decoder True- where- sql =- "select $1"- encoder =- Encoders.param (Encoders.nonNullable (Encoders.text))- decoder =- (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text)))- effect2 =- DSL.statement 1 statement- where- statement =- Statement.Statement sql encoder decoder True- where- sql =- "select $1"- encoder =- Encoders.param (Encoders.nonNullable (Encoders.int8))- decoder =- (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8))- in (,) <$> effect1 <*> effect2- in actualIO >>= assertEqual "" (Right ("ok", 1)),- testCase "Affected rows counting" $- replicateM_ 13 $- let actualIO =++ assertEqual "" (Right "ok") res+ ],+ testCase "Composite encoding" $ do+ let value =+ (123, 456, 789, "abc")+ res <-+ let statement =+ Statement.Statement sql encoder decoder True+ where+ sql =+ "select $1 :: pg_enum"+ encoder =+ Encoders.param+ . Encoders.nonNullable+ . Encoders.composite+ . mconcat+ $ [ contramap (\(a, _, _, _) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.oid,+ contramap (\(_, a, _, _) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.oid,+ contramap (\(_, _, a, _) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.float4,+ contramap (\(_, _, _, a) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.name+ ]+ decoder =+ Decoders.singleRow+ $ (Decoders.column . Decoders.nonNullable . Decoders.composite)+ ( (,,,)+ <$> (Decoders.field . Decoders.nonNullable) Decoders.int4+ <*> (Decoders.field . Decoders.nonNullable) Decoders.int4+ <*> (Decoders.field . Decoders.nonNullable) Decoders.float4+ <*> (Decoders.field . Decoders.nonNullable) Decoders.text+ )+ in Connection.with $ Session.run $ Session.statement value statement+ assertEqual "" (Right (Right value)) res,+ testCase "Empty array"+ $ let io =+ do+ x <- Connection.with (Session.run session)+ assertEqual (show x) (Right (Right [])) x+ where+ session =+ Session.statement () statement+ where+ statement =+ Statement.Statement sql encoder decoder True+ where+ sql =+ "select array[]::int8[]"+ encoder =+ mempty+ decoder =+ Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.array (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8)))))+ in io,+ testCase "Failing prepared statements"+ $ let io =+ Connection.with (Session.run session)+ >>= (assertBool <$> show <*> resultTest)+ where+ resultTest =+ \case+ Right (Left (Session.QueryError _ _ (Session.ResultError (Session.ServerError "26000" _ _ _ _)))) -> False+ _ -> True+ session =+ catchError session (const (pure ())) *> session+ where+ session =+ Session.statement () statement+ where+ statement =+ Statement.Statement sql encoder decoder True+ where+ sql =+ "absurd"+ encoder =+ mempty+ decoder =+ Decoders.noResult+ 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.statement 1 statement+ where+ statement =+ Statement.Statement sql encoder decoder True+ where+ sql =+ "select $1 :: int8"+ encoder =+ Encoders.param (Encoders.nonNullable (Encoders.int8))+ decoder =+ Decoders.singleRow $ (Decoders.column . Decoders.nonNullable) Decoders.int8+ fail =+ catchError (Session.sql "absurd") (const (pure ()))+ in io,+ testCase "\"in progress after error\" bugfix"+ $ let sumStatement :: Statement.Statement (Int64, Int64) Int64+ sumStatement =+ Statement.Statement sql encoder decoder True+ where+ sql =+ "select ($1 + $2)"+ encoder =+ contramap fst (Encoders.param (Encoders.nonNullable (Encoders.int8)))+ <> contramap snd (Encoders.param (Encoders.nonNullable (Encoders.int8)))+ decoder =+ Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8)+ sumSession :: Session.Session Int64+ sumSession =+ Session.sql "begin" *> Session.statement (1, 1) sumStatement <* Session.sql "end"+ errorSession :: Session.Session ()+ errorSession =+ Session.sql "asldfjsldk"+ io =+ Connection.with $ \c -> do+ Session.run errorSession c+ Session.run sumSession c+ in io >>= \x -> assertBool (show x) (either (const False) isRight x),+ testCase "\"another command is already in progress\" bugfix"+ $ let sumStatement :: Statement.Statement (Int64, Int64) Int64+ sumStatement =+ Statement.Statement sql encoder decoder True+ where+ sql =+ "select ($1 + $2)"+ encoder =+ contramap fst (Encoders.param (Encoders.nonNullable (Encoders.int8)))+ <> contramap snd (Encoders.param (Encoders.nonNullable (Encoders.int8)))+ decoder =+ Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8)+ session :: Session.Session Int64+ session =+ do+ Session.sql "begin;"+ s <- Session.statement (1, 1) sumStatement+ Session.sql "end;"+ return s+ in DSL.session session >>= \x -> assertEqual (show x) (Right 2) x,+ testCase "Executing the same query twice"+ $ pure (),+ testCase "Interval Encoding"+ $ let actualIO = DSL.session $ do+ let statement =+ Statement.Statement sql encoder decoder True+ where+ sql =+ "select $1 = interval '10 seconds'"+ decoder =+ (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool)))+ encoder =+ Encoders.param (Encoders.nonNullable (Encoders.interval))+ in DSL.statement (10 :: DiffTime) statement+ in actualIO >>= \x -> assertEqual (show x) (Right True) x,+ testCase "Interval Decoding"+ $ let actualIO =+ DSL.session $ do+ let statement =+ Statement.Statement sql encoder decoder True+ where+ sql =+ "select interval '10 seconds'"+ decoder =+ (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval)))+ encoder =+ Encoders.noParams+ in DSL.statement () statement+ in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x,+ testCase "Interval Encoding/Decoding"+ $ let actualIO =+ DSL.session $ do+ let statement =+ Statement.Statement sql encoder decoder True+ where+ sql =+ "select $1"+ decoder =+ (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval)))+ encoder =+ Encoders.param (Encoders.nonNullable (Encoders.interval))+ in DSL.statement (10 :: DiffTime) statement+ in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x,+ testCase "Unknown"+ $ let actualIO =+ DSL.session $ do+ let statement =+ Statement.Statement sql mempty Decoders.noResult True+ where+ sql =+ "drop type if exists mood"+ in DSL.statement () statement+ let statement =+ Statement.Statement sql mempty Decoders.noResult True+ where+ sql =+ "create type mood as enum ('sad', 'ok', 'happy')"+ in DSL.statement () statement+ let statement =+ Statement.Statement sql encoder decoder True+ where+ sql =+ "select $1 = ('ok' :: mood)"+ decoder =+ (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool)))+ encoder =+ Encoders.param (Encoders.nonNullable (Encoders.unknown))+ in DSL.statement "ok" statement+ in actualIO >>= assertEqual "" (Right True),+ testCase "Textual Unknown"+ $ let actualIO =+ DSL.session $ do+ let statement =+ Statement.Statement sql mempty Decoders.noResult True+ where+ sql =+ "create or replace function overloaded(a int, b int) returns int as $$ select a + b $$ language sql;"+ in DSL.statement () statement+ let statement =+ Statement.Statement sql mempty Decoders.noResult True+ where+ sql =+ "create or replace function overloaded(a text, b text, c text) returns text as $$ select a || b || c $$ language sql;"+ in DSL.statement () statement+ let statement =+ Statement.Statement sql encoder decoder True+ where+ sql =+ "select overloaded($1, $2) || overloaded($3, $4, $5)"+ decoder =+ (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text)))+ encoder =+ contramany (Encoders.param (Encoders.nonNullable (Encoders.unknown)))+ in DSL.statement ["1", "2", "4", "5", "6"] statement+ in actualIO >>= assertEqual "" (Right "3456"),+ testCase "Enum"+ $ let actualIO =+ DSL.session $ do+ let statement =+ Statement.Statement sql mempty Decoders.noResult True+ where+ sql =+ "drop type if exists mood"+ in DSL.statement () statement+ let statement =+ Statement.Statement sql mempty Decoders.noResult True+ where+ sql =+ "create type mood as enum ('sad', 'ok', 'happy')"+ in DSL.statement () statement+ let statement =+ Statement.Statement sql encoder decoder True+ where+ sql =+ "select ($1 :: mood)"+ decoder =+ (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.enum (Just . id))))+ encoder =+ Encoders.param (Encoders.nonNullable ((Encoders.enum id)))+ in DSL.statement "ok" statement+ in actualIO >>= assertEqual "" (Right "ok"),+ testCase "The same prepared statement used on different types"+ $ let actualIO =+ DSL.session $ do+ let effect1 =+ DSL.statement "ok" statement+ where+ statement =+ Statement.Statement sql encoder decoder True+ where+ sql =+ "select $1"+ encoder =+ Encoders.param (Encoders.nonNullable (Encoders.text))+ decoder =+ (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text)))+ effect2 =+ DSL.statement 1 statement+ where+ statement =+ Statement.Statement sql encoder decoder True+ where+ sql =+ "select $1"+ encoder =+ Encoders.param (Encoders.nonNullable (Encoders.int8))+ decoder =+ (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8))+ in (,) <$> effect1 <*> effect2+ in actualIO >>= assertEqual "" (Right ("ok", 1)),+ testCase "Affected rows counting"+ $ replicateM_ 13+ $ let actualIO =+ DSL.session $ do dropTable createTable replicateM_ 100 insertRow deleteRows <* dropTable where dropTable =- DSL.statement () $- Statements.plain $- "drop table if exists a"+ DSL.statement ()+ $ Statements.plain+ $ "drop table if exists a" createTable =- DSL.statement () $- Statements.plain $- "create table a (id bigserial not null, name varchar not null, primary key (id))"+ DSL.statement ()+ $ Statements.plain+ $ "create table a (id bigserial not null, name varchar not null, primary key (id))" insertRow =- DSL.statement () $- Statements.plain $- "insert into a (name) values ('a')"+ DSL.statement ()+ $ Statements.plain+ $ "insert into a (name) values ('a')" deleteRows = DSL.statement () $ Statement.Statement sql mempty decoder False where@@ -472,18 +482,18 @@ decoder = Decoders.rowsAffected in actualIO >>= assertEqual "" (Right 100),- testCase "Result of an auto-incremented column" $- let actualIO =- DSL.session $ do- DSL.statement () $ Statements.plain $ "drop table if exists a"- DSL.statement () $ Statements.plain $ "create table a (id serial not null, v char not null, primary key (id))"- id1 <- DSL.statement () $ Statement.Statement "insert into a (v) values ('a') returning id" mempty (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int4)) False- id2 <- DSL.statement () $ Statement.Statement "insert into a (v) values ('b') returning id" mempty (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int4)) False- DSL.statement () $ Statements.plain $ "drop table if exists a"- pure (id1, id2)- in assertEqual "" (Right (1, 2)) =<< actualIO,- testCase "List decoding" $- let actualIO =- DSL.session $ DSL.statement () $ Statements.selectList- in assertEqual "" (Right [(1, 2), (3, 4), (5, 6)]) =<< actualIO+ testCase "Result of an auto-incremented column"+ $ let actualIO =+ DSL.session $ do+ DSL.statement () $ Statements.plain $ "drop table if exists a"+ DSL.statement () $ Statements.plain $ "create table a (id serial not null, v char not null, primary key (id))"+ id1 <- DSL.statement () $ Statement.Statement "insert into a (v) values ('a') returning id" mempty (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int4)) False+ id2 <- DSL.statement () $ Statement.Statement "insert into a (v) values ('b') returning id" mempty (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int4)) False+ DSL.statement () $ Statements.plain $ "drop table if exists a"+ pure (id1, id2)+ in assertEqual "" (Right (1, 2)) =<< actualIO,+ testCase "List decoding"+ $ let actualIO =+ DSL.session $ DSL.statement () $ Statements.selectList+ in assertEqual "" (Right [(1, 2), (3, 4), (5, 6)]) =<< actualIO ]
tasty/Main/Connection.hs view
@@ -1,8 +1,6 @@ module Main.Connection where import qualified Hasql.Connection as HC-import qualified Hasql.Session-import qualified Hasql.Statement as HQ import Main.Prelude with :: (HC.Connection -> IO a) -> IO (Either HC.ConnectionError a)@@ -18,7 +16,7 @@ host = "localhost" port = 5432 user = "postgres"- password = ""+ password = "postgres" database = "postgres" use connection = lift $ handler connection
tasty/Main/DSL.hs view
@@ -8,10 +8,7 @@ where import qualified Hasql.Connection as HC-import qualified Hasql.Decoders as HD-import qualified Hasql.Encoders as HE import qualified Hasql.Session-import qualified Hasql.Statement as HQ import Main.Prelude type Session =@@ -35,11 +32,11 @@ host = "localhost" port = 5432 user = "postgres"- password = ""+ password = "postgres" database = "postgres" use connection =- ExceptT $- fmap (mapLeft SessionError) $- Hasql.Session.run session connection+ ExceptT+ $ fmap (mapLeft SessionError)+ $ Hasql.Session.run session connection release connection = lift $ HC.release connection
tasty/Main/Statements.hs view
@@ -1,10 +1,8 @@ module Main.Statements where import qualified Hasql.Decoders as HD-import qualified Hasql.Encoders as HE import qualified Hasql.Statement as HQ import Main.Prelude-import qualified Main.Prelude as Prelude plain :: ByteString -> HQ.Statement () () plain sql =@@ -12,15 +10,18 @@ dropType :: ByteString -> HQ.Statement () () dropType name =- plain $- "drop type if exists " <> name+ plain+ $ "drop type if exists "+ <> name createEnum :: ByteString -> [ByteString] -> HQ.Statement () () createEnum name values =- plain $- "create type " <> name <> " as enum ("- <> mconcat (intersperse ", " (map (\x -> "'" <> x <> "'") values))- <> ")"+ plain+ $ "create type "+ <> name+ <> " as enum ("+ <> mconcat (intersperse ", " (map (\x -> "'" <> x <> "'") values))+ <> ")" selectList :: HQ.Statement () ([] (Int64, Int64)) selectList =
threads-test/Main.hs view
@@ -1,13 +1,11 @@ module Main where import qualified Hasql.Connection-import qualified Hasql.Decoders-import qualified Hasql.Encoders import qualified Hasql.Session-import qualified Hasql.Statement import qualified Main.Statements as Statements import Prelude +main :: IO () main = acquire >>= use where@@ -15,12 +13,12 @@ (,) <$> acquire <*> acquire where acquire =- join $- fmap (either (fail . show) return) $- Hasql.Connection.acquire connectionSettings+ join+ $ fmap (either (fail . show) return)+ $ Hasql.Connection.acquire connectionSettings where connectionSettings =- Hasql.Connection.settings "localhost" 5432 "postgres" "" "postgres"+ Hasql.Connection.settings "localhost" 5432 "postgres" "postgres" "postgres" use (connection1, connection2) = do beginVar <- newEmptyMVar