nikita-volkov/hasql
1
1
Fork 0
mirror of https://github.com/nikita-volkov/hasql.git synced 2024-11-22 01:52:45 +03:00
Code Issues Projects Releases Wiki Activity

Reimplement to add support for query param printing in failed queries

Browse Source
This commit is contained in:
Nikita Volkov 2018-05-23 17:15:34 +08:00
parent 151e91451f
commit ea4874ca7e
21 changed files with 401 additions and 455 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
benchmarks/Main.hs
View File

@ -69,7 +69,7 @@ queryWithManyParameters =
queryWithSingleRow :: C.Query () (Int64, Int64)
queryWithSingleRow =
C.statement template encoder decoder True
C.Query template encoder decoder True
where
template =
"SELECT 1, 2"
@ -86,7 +86,7 @@ queryWithSingleRow =
queryWithManyRows :: (D.Row (Int64, Int64) -> D.Result result) -> C.Query () result
queryWithManyRows decoder =
C.statement template encoder (decoder rowDecoder) True
C.Query template encoder (decoder rowDecoder) True
where
template =
"SELECT generate_series(0,1000) as a, generate_series(1000,2000) as b"

15
hasql.cabal
View File

@ -47,11 +47,17 @@ library
Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples
default-language:
Haskell2010
exposed-modules:
Hasql.Decoders
Hasql.Encoders
Hasql.Connection
Hasql.Query
Hasql.Session
other-modules:
Hasql.Private.Prelude
Hasql.Private.Errors
Hasql.Private.PTI
Hasql.Private.IO
Hasql.Private.Query
Hasql.Private.Session
Hasql.Private.Connection
Hasql.Private.PreparedStatementRegistry
@ -66,12 +72,6 @@ library
Hasql.Private.Encoders.Array
Hasql.Private.Encoders.Value
Hasql.Private.Encoders.Params
exposed-modules:
Hasql.Decoders
Hasql.Encoders
Hasql.Connection
Hasql.Query
Hasql.Session
build-depends:
-- parsing:
attoparsec >= 0.10 && < 0.14,
@ -85,6 +85,7 @@ library
vector >= 0.10 && < 0.13,
hashtables >= 1.1 && < 2,
text >= 1 && < 2,
text-builder >= 0.5.1 && < 0.6,
bytestring >= 0.10 && < 0.11,
hashable >= 1.2 && < 1.3,
-- control:

65
library/Hasql/Encoders.hs
View File

@ -47,6 +47,7 @@ where
import Hasql.Private.Prelude hiding (bool)
import qualified PostgreSQL.Binary.Encoding as A
import qualified PostgreSQL.Binary.Data as B
import qualified Text.Builder as C
import qualified Hasql.Private.Encoders.Params as Params
import qualified Hasql.Private.Encoders.Value as Value
import qualified Hasql.Private.Encoders.Array as Array
@ -187,49 +188,49 @@ newtype Value a =
{-# INLINABLE bool #-}
bool :: Value Bool
bool =
Value (Value.unsafePTI PTI.bool (const A.bool))
Value (Value.unsafePTIWithShow PTI.bool (const A.bool))
-- |
-- Encoder of @INT2@ values.
{-# INLINABLE int2 #-}
int2 :: Value Int16
int2 =
Value (Value.unsafePTI PTI.int2 (const A.int2_int16))
Value (Value.unsafePTIWithShow PTI.int2 (const A.int2_int16))
-- |
-- Encoder of @INT4@ values.
{-# INLINABLE int4 #-}
int4 :: Value Int32
int4 =
Value (Value.unsafePTI PTI.int4 (const A.int4_int32))
Value (Value.unsafePTIWithShow PTI.int4 (const A.int4_int32))
-- |
-- Encoder of @INT8@ values.
{-# INLINABLE int8 #-}
int8 :: Value Int64
int8 =
Value (Value.unsafePTI PTI.int8 (const A.int8_int64))
Value (Value.unsafePTIWithShow PTI.int8 (const A.int8_int64))
-- |
-- Encoder of @FLOAT4@ values.
{-# INLINABLE float4 #-}
float4 :: Value Float
float4 =
Value (Value.unsafePTI PTI.float4 (const A.float4))
Value (Value.unsafePTIWithShow PTI.float4 (const A.float4))
-- |
-- Encoder of @FLOAT8@ values.
{-# INLINABLE float8 #-}
float8 :: Value Double
float8 =
Value (Value.unsafePTI PTI.float8 (const A.float8))
Value (Value.unsafePTIWithShow PTI.float8 (const A.float8))
-- |
-- Encoder of @NUMERIC@ values.
{-# INLINABLE numeric #-}
numeric :: Value B.Scientific
numeric =
Value (Value.unsafePTI PTI.numeric (const A.numeric))
Value (Value.unsafePTIWithShow PTI.numeric (const A.numeric))
-- |
-- Encoder of @CHAR@ values.
@ -238,113 +239,115 @@ numeric =
{-# INLINABLE char #-}
char :: Value Char
char =
Value (Value.unsafePTI PTI.text (const A.char_utf8))
Value (Value.unsafePTIWithShow PTI.text (const A.char_utf8))
-- |
-- Encoder of @TEXT@ values.
{-# INLINABLE text #-}
text :: Value Text
text =
Value (Value.unsafePTI PTI.text (const A.text_strict))
Value (Value.unsafePTIWithShow PTI.text (const A.text_strict))
-- |
-- Encoder of @BYTEA@ values.
{-# INLINABLE bytea #-}
bytea :: Value ByteString
bytea =
Value (Value.unsafePTI PTI.bytea (const A.bytea_strict))
Value (Value.unsafePTIWithShow PTI.bytea (const A.bytea_strict))
-- |
-- Encoder of @DATE@ values.
{-# INLINABLE date #-}
date :: Value B.Day
date =
Value (Value.unsafePTI PTI.date (const A.date))
Value (Value.unsafePTIWithShow PTI.date (const A.date))
-- |
-- Encoder of @TIMESTAMP@ values.
{-# INLINABLE timestamp #-}
timestamp :: Value B.LocalTime
timestamp =
Value (Value.unsafePTI PTI.timestamp (Prelude.bool A.timestamp_float A.timestamp_int))
Value (Value.unsafePTIWithShow PTI.timestamp (Prelude.bool A.timestamp_float A.timestamp_int))
-- |
-- Encoder of @TIMESTAMPTZ@ values.
{-# INLINABLE timestamptz #-}
timestamptz :: Value B.UTCTime
timestamptz =
Value (Value.unsafePTI PTI.timestamptz (Prelude.bool A.timestamptz_float A.timestamptz_int))
Value (Value.unsafePTIWithShow PTI.timestamptz (Prelude.bool A.timestamptz_float A.timestamptz_int))
-- |
-- Encoder of @TIME@ values.
{-# INLINABLE time #-}
time :: Value B.TimeOfDay
time =
Value (Value.unsafePTI PTI.time (Prelude.bool A.time_float A.time_int))
Value (Value.unsafePTIWithShow PTI.time (Prelude.bool A.time_float A.time_int))
-- |
-- Encoder of @TIMETZ@ values.
{-# INLINABLE timetz #-}
timetz :: Value (B.TimeOfDay, B.TimeZone)
timetz =
Value (Value.unsafePTI PTI.timetz (Prelude.bool A.timetz_float A.timetz_int))
Value (Value.unsafePTIWithShow PTI.timetz (Prelude.bool A.timetz_float A.timetz_int))
-- |
-- Encoder of @INTERVAL@ values.
{-# INLINABLE interval #-}
interval :: Value B.DiffTime
interval =
Value (Value.unsafePTI PTI.interval (Prelude.bool A.interval_float A.interval_int))
Value (Value.unsafePTIWithShow PTI.interval (Prelude.bool A.interval_float A.interval_int))
-- |
-- Encoder of @UUID@ values.
{-# INLINABLE uuid #-}
uuid :: Value B.UUID
uuid =
Value (Value.unsafePTI PTI.uuid (const A.uuid))
Value (Value.unsafePTIWithShow PTI.uuid (const A.uuid))
-- |
-- Encoder of @INET@ values.
{-# INLINABLE inet #-}
inet :: Value (B.NetAddr B.IP)
inet =
Value (Value.unsafePTI PTI.inet (const A.inet))
Value (Value.unsafePTIWithShow PTI.inet (const A.inet))
-- |
-- Encoder of @JSON@ values from JSON AST.
{-# INLINABLE json #-}
json :: Value B.Value
json =
Value (Value.unsafePTI PTI.json (const A.json_ast))
Value (Value.unsafePTIWithShow PTI.json (const A.json_ast))
-- |
-- Encoder of @JSON@ values from raw JSON.
{-# INLINABLE jsonBytes #-}
jsonBytes :: Value ByteString
jsonBytes =
Value (Value.unsafePTI PTI.json (const A.json_bytes))
Value (Value.unsafePTIWithShow PTI.json (const A.json_bytes))
-- |
-- Encoder of @JSONB@ values from JSON AST.
{-# INLINABLE jsonb #-}
jsonb :: Value B.Value
jsonb =
Value (Value.unsafePTI PTI.jsonb (const A.jsonb_ast))
Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_ast))
-- |
-- Encoder of @JSONB@ values from raw JSON.
{-# INLINABLE jsonbBytes #-}
jsonbBytes :: Value ByteString
jsonbBytes =
Value (Value.unsafePTI PTI.jsonb (const A.jsonb_bytes))
Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_bytes))
-- |
-- Unlifts the 'Array' encoder to the plain 'Value' encoder.
{-# INLINABLE array #-}
array :: Array a -> Value a
array (Array imp) =
Array.run imp & \(arrayOID, encoder') ->
Value (Value.Value arrayOID arrayOID encoder')
array (Array (Array.Array valueOID arrayOID arrayEncoder renderer)) =
let
encoder env input =
A.array (PTI.oidWord32 valueOID) (arrayEncoder env input)
in Value (Value.Value arrayOID arrayOID encoder renderer)
-- |
-- Given a function,
@ -353,7 +356,7 @@ array (Array imp) =
{-# INLINABLE enum #-}
enum :: (a -> Text) -> Value a
enum mapping =
Value (Value.unsafePTI PTI.text (const (A.text_strict . mapping)))
Value (Value.unsafePTI PTI.text (const (A.text_strict . mapping)) (C.text . mapping))
-- |
-- Identifies the value with the PostgreSQL's \"unknown\" type,
@ -366,7 +369,7 @@ enum mapping =
{-# INLINABLE unknown #-}
unknown :: Value ByteString
unknown =
Value (Value.unsafePTI PTI.unknown (const A.bytea_strict))
Value (Value.unsafePTIWithShow PTI.unknown (const A.bytea_strict))
-- ** Instances
@ -503,15 +506,15 @@ newtype Array a =
-- Lifts the 'Value' encoder into the 'Array' encoder of a non-nullable value.
{-# INLINABLE arrayValue #-}
arrayValue :: Value a -> Array a
arrayValue (Value (Value.Value elementOID arrayOID encoder')) =
Array (Array.value elementOID arrayOID encoder')
arrayValue (Value (Value.Value elementOID arrayOID encoder renderer)) =
Array (Array.value elementOID arrayOID encoder renderer)
-- |
-- Lifts the 'Value' encoder into the 'Array' encoder of a nullable value.
{-# INLINABLE arrayNullableValue #-}
arrayNullableValue :: Value a -> Array (Maybe a)
arrayNullableValue (Value (Value.Value elementOID arrayOID encoder')) =
Array (Array.nullableValue elementOID arrayOID encoder')
arrayNullableValue (Value (Value.Value elementOID arrayOID encoder renderer)) =
Array (Array.nullableValue elementOID arrayOID encoder renderer)
-- |
-- An encoder of an array dimension,

36
library/Hasql/Private/Decoders/Result.hs
View File

@ -1,6 +1,7 @@
module Hasql.Private.Decoders.Result where
import Hasql.Private.Prelude hiding (maybe, many)
import Hasql.Private.Errors
import qualified Database.PostgreSQL.LibPQ as LibPQ
import qualified Hasql.Private.Decoders.Row as Row
import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec
@ -11,42 +12,11 @@ import qualified Data.Vector.Mutable as MutableVector
newtype Result a =
Result (ReaderT (Bool, LibPQ.Result) (ExceptT Error IO) a)
Result (ReaderT (Bool, LibPQ.Result) (ExceptT ResultError IO) a)
deriving (Functor, Applicative, Monad)
data Error =
-- |
-- 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.
ServerError !ByteString !ByteString !(Maybe ByteString) !(Maybe ByteString) |
-- |
-- The database returned an unexpected result.
-- Indicates an improper statement or a schema mismatch.
UnexpectedResult !Text |
-- |
-- An error of the row reader, preceded by the index of the row.
RowError !Int !Row.Error |
-- |
-- An unexpected amount of rows.
UnexpectedAmountOfRows !Int
deriving (Show)
{-# INLINE run #-}
run :: Result a -> (Bool, LibPQ.Result) -> IO (Either Error a)
run :: Result a -> (Bool, LibPQ.Result) -> IO (Either ResultError a)
run (Result reader) env =
runExceptT (runReaderT reader env)

13
library/Hasql/Private/Decoders/Results.hs
View File

@ -12,6 +12,7 @@
module Hasql.Private.Decoders.Results where
import Hasql.Private.Prelude hiding (maybe, many)
import Hasql.Private.Errors
import qualified Database.PostgreSQL.LibPQ as LibPQ
import qualified Hasql.Private.Prelude as Prelude
import qualified Hasql.Private.Decoders.Result as Result
@ -19,20 +20,12 @@ import qualified Hasql.Private.Decoders.Row as Row
newtype Results a =
Results (ReaderT (Bool, LibPQ.Connection) (ExceptT Error IO) a)
Results (ReaderT (Bool, LibPQ.Connection) (ExceptT CommandError IO) a)
deriving (Functor, Applicative, Monad)
data Error =
-- |
-- An error on the client-side,
-- with a message generated by the \"libpq\" library.
-- Usually indicates problems with the connection.
ClientError !(Maybe ByteString) |
ResultError !Result.Error
deriving (Show)
{-# INLINE run #-}
run :: Results a -> (Bool, LibPQ.Connection) -> IO (Either Error a)
run :: Results a -> (Bool, LibPQ.Connection) -> IO (Either CommandError a)
run (Results stack) env =
runExceptT (runReaderT stack env)

13
library/Hasql/Private/Decoders/Row.hs
View File

@ -1,37 +1,32 @@
module Hasql.Private.Decoders.Row where
import Hasql.Private.Prelude
import Hasql.Private.Errors
import qualified Database.PostgreSQL.LibPQ as LibPQ
import qualified PostgreSQL.Binary.Decoding as A
import qualified Hasql.Private.Decoders.Value as Value
newtype Row a =
Row (ReaderT Env (ExceptT Error IO) a)
Row (ReaderT Env (ExceptT RowError IO) a)
deriving (Functor, Applicative, Monad)
data Env =
Env !LibPQ.Result !LibPQ.Row !LibPQ.Column !Bool !(IORef LibPQ.Column)
data Error =
EndOfInput |
UnexpectedNull |
ValueError !Text
deriving (Show)
-- * Functions
-------------------------
{-# INLINE run #-}
run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either Error a)
run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either RowError a)
run (Row impl) (result, row, columnsAmount, integerDatetimes) =
do
columnRef <- newIORef 0
runExceptT (runReaderT impl (Env result row columnsAmount integerDatetimes columnRef))
{-# INLINE error #-}
error :: Error -> Row a
error :: RowError -> Row a
error x =
Row (ReaderT (const (ExceptT (pure (Left x)))))

41
library/Hasql/Private/Encoders/Array.hs
View File

@ -3,28 +3,43 @@ module Hasql.Private.Encoders.Array where
import Hasql.Private.Prelude
import qualified PostgreSQL.Binary.Encoding as A
import qualified Hasql.Private.PTI as B
import qualified Text.Builder as C
data Array a =
Array B.OID B.OID (Bool -> a -> A.Array)
{-# INLINE run #-}
run :: Array a -> (B.OID, Bool -> a -> A.Encoding)
run (Array valueOID arrayOID encoder) =
(arrayOID, \env input -> A.array (B.oidWord32 valueOID) (encoder env input))
Array B.OID B.OID (Bool -> a -> A.Array) (a -> C.Builder)
{-# INLINE value #-}
value :: B.OID -> B.OID -> (Bool -> a -> A.Encoding) -> Array a
value :: B.OID -> B.OID -> (Bool -> a -> A.Encoding) -> (a -> C.Builder) -> Array a
value valueOID arrayOID encoder =
Array valueOID arrayOID (\params -> A.encodingArray . encoder params)
{-# INLINE nullableValue #-}
nullableValue :: B.OID -> B.OID -> (Bool -> a -> A.Encoding) -> Array (Maybe a)
nullableValue valueOID arrayOID encoder =
Array valueOID arrayOID (\params -> maybe A.nullArray (A.encodingArray . encoder params))
nullableValue :: B.OID -> B.OID -> (Bool -> a -> A.Encoding) -> (a -> C.Builder) -> Array (Maybe a)
nullableValue valueOID arrayOID encoder renderer =
let
maybeEncoder params =
maybe A.nullArray (A.encodingArray . encoder params)
maybeRenderer =
maybe (C.string "null") renderer
in Array valueOID arrayOID maybeEncoder maybeRenderer
{-# INLINE dimension #-}
dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c
dimension fold (Array valueOID arrayOID encoder) =
Array valueOID arrayOID (\params -> A.dimensionArray fold (encoder params))
dimension fold (Array valueOID arrayOID elEncoder elRenderer) =
let
encoder el =
A.dimensionArray fold (elEncoder el)
renderer els =
let
folded =
let
step builder el =
if C.null builder
then C.char '[' <> elRenderer el
else builder <> C.string ", " <> elRenderer el
in fold step mempty els
in if C.null folded
then C.string "[]"
else folded <> C.char ']'
in Array valueOID arrayOID encoder renderer

47
library/Hasql/Private/Encoders/Params.hs
View File

@ -5,52 +5,29 @@ import qualified Database.PostgreSQL.LibPQ as A
import qualified PostgreSQL.Binary.Encoding as B
import qualified Hasql.Private.Encoders.Value as C
import qualified Hasql.Private.PTI as D
import qualified Text.Builder as E
-- |
-- Encoder of some representation of a parameters product.
newtype Params a =
Params (Op (DList (A.Oid, Bool -> Maybe ByteString)) a)
Params (Op (DList (A.Oid, A.Format, Bool -> Maybe ByteString, Text)) a)
deriving (Contravariant, Divisible, Decidable, Monoid)
instance Semigroup (Params a)
run :: Params a -> a -> DList (A.Oid, Bool -> Maybe ByteString)
run (Params (Op op)) params =
{-# SCC "run" #-}
op params
run' :: Params a -> a -> Bool -> ([A.Oid], [Maybe (ByteString, A.Format)])
run' (Params (Op op)) params integerDatetimes =
{-# SCC "run'" #-}
foldr step ([], []) (op params)
where
step (oid, bytesGetter) ~(oidList, bytesAndFormatList) =
(,)
(oid : oidList)
(fmap (\bytes -> (bytes, format oid)) (bytesGetter integerDatetimes) : bytesAndFormatList)
run'' :: Params a -> a -> Bool -> [Maybe (A.Oid, ByteString, A.Format)]
run'' (Params (Op op)) params integerDatetimes =
{-# SCC "run''" #-}
foldr step [] (op params)
where
step a b =
mapping a : b
where
mapping (oid, bytesGetter) =
(,,) <$> pure oid <*> bytesGetter integerDatetimes <*> pure (format oid)
format :: A.Oid -> A.Format
format oid = case oid of
A.Oid 705 -> A.Text -- is unknown
_ -> A.Binary
value :: C.Value a -> Params a
value =
contramap Just . nullableValue
nullableValue :: C.Value a -> Params (Maybe a)
nullableValue (C.Value valueOID arrayOID encoder) =
Params $ Op $ \input ->
pure (D.oidPQ valueOID, \env -> fmap (B.encodingBytes . encoder env) input)
nullableValue (C.Value valueOID arrayOID encode render) =
Params $ Op $ \ input ->
let
D.OID _ pqOid format =
valueOID
encoder env =
fmap (B.encodingBytes . encode env) input
rendering =
maybe "null" (E.run . render) input
in pure (pqOid, format, encoder, rendering)

23
library/Hasql/Private/Encoders/Value.hs
View File

@ -3,24 +3,23 @@ module Hasql.Private.Encoders.Value where
import Hasql.Private.Prelude
import qualified PostgreSQL.Binary.Encoding as B
import qualified Hasql.Private.PTI as PTI
import qualified Text.Builder as C
data Value a =
Value PTI.OID PTI.OID (Bool -> a -> B.Encoding)
Value PTI.OID PTI.OID (Bool -> a -> B.Encoding) (a -> C.Builder)
instance Contravariant Value where
{-# INLINE contramap #-}
contramap f (Value valueOID arrayOID encoder) =
Value valueOID arrayOID (\integerDatetimes input -> encoder integerDatetimes (f input))
{-# INLINE run #-}
run :: Value a -> (PTI.OID, PTI.OID, Bool -> a -> B.Encoding)
run (Value valueOID arrayOID encoder') =
(valueOID, arrayOID, encoder')
contramap f (Value valueOID arrayOID encode render) =
Value valueOID arrayOID (\integerDatetimes input -> encode integerDatetimes (f input)) (render . f)
{-# INLINE unsafePTI #-}
unsafePTI :: PTI.PTI -> (Bool -> a -> B.Encoding) -> Value a
unsafePTI pti encoder' =
Value (PTI.ptiOID pti) (fromMaybe ($bug "No array OID") (PTI.ptiArrayOID pti)) encoder'
unsafePTI :: PTI.PTI -> (Bool -> a -> B.Encoding) -> (a -> C.Builder) -> Value a
unsafePTI pti =
Value (PTI.ptiOID pti) (fromMaybe ($bug "No array OID") (PTI.ptiArrayOID pti))
{-# INLINE unsafePTIWithShow #-}
unsafePTIWithShow :: Show a => PTI.PTI -> (Bool -> a -> B.Encoding) -> Value a
unsafePTIWithShow pti encode =
unsafePTI pti encode (C.string . show)

88
library/Hasql/Private/Errors.hs Normal file
View File

@ -0,0 +1,88 @@
-- |
-- An API for retrieval of multiple results.
-- Can be used to handle:
--
-- * A single result,
--
-- * Individual results of a multi-statement query
-- with the help of "Applicative" and "Monad",
--
-- * Row-by-row fetching.
--
module Hasql.Private.Errors where
import Hasql.Private.Prelude
-- |
-- An error during the execution of a query.
-- Comes packed with the query template and a textual representation of the provided params.
data QueryError =
QueryError ByteString [Text] CommandError
deriving (Show, Eq)
-- |
-- An error of some command in the session.
data CommandError =
-- |
-- An error on the client-side,
-- with a message generated by the \"libpq\" library.
-- Usually indicates problems with connection.
ClientError (Maybe ByteString) |
-- |
-- Some error with a command result.
ResultError ResultError
deriving (Show, Eq)
-- |
-- An error with a command result.
data ResultError =
-- |
-- An error reported by the DB.
-- Consists of the following: Code, message, details, hint.
--
-- * __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.
--
-- * __Message__.
-- The primary human-readable error message (typically one line). Always present.
--
-- * __Details__.
-- An optional secondary error message carrying more detail about the problem.
-- Might run to multiple lines.
--
-- * __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.
ServerError ByteString ByteString (Maybe ByteString) (Maybe ByteString) |
-- |
-- The database returned an unexpected result.
-- Indicates an improper statement or a schema mismatch.
UnexpectedResult Text |
-- |
-- An error of the row reader, preceded by the index of the row.
RowError Int RowError |
-- |
-- An unexpected amount of rows.
UnexpectedAmountOfRows Int
deriving (Show, Eq)
-- |
-- An error during the decoding of a specific row.
data RowError =
-- |
-- Appears on the attempt to parse more columns than there are in the result.
EndOfInput |
-- |
-- Appears on the attempt to parse a @NULL@ as some value.
UnexpectedNull |
-- |
-- Appears when a wrong value parser is used.
-- Comes with the error details.
ValueError Text
deriving (Show, Eq)

66
library/Hasql/Private/IO.hs
View File

@ -4,6 +4,7 @@ module Hasql.Private.IO
where
import Hasql.Private.Prelude
import Hasql.Private.Errors
import qualified Database.PostgreSQL.LibPQ as LibPQ
import qualified Hasql.Private.Commands as Commands
import qualified Hasql.Private.PreparedStatementRegistry as PreparedStatementRegistry
@ -58,7 +59,7 @@ initConnection c =
void $ LibPQ.exec c (Commands.asBytes (Commands.setEncodersToUTF8 <> Commands.setMinClientMessagesToWarning))
{-# INLINE getResults #-}
getResults :: LibPQ.Connection -> Bool -> ResultsDecoders.Results a -> IO (Either ResultsDecoders.Error a)
getResults :: LibPQ.Connection -> Bool -> ResultsDecoders.Results a -> IO (Either CommandError a)
getResults connection integerDatetimes decoder =
{-# SCC "getResults" #-}
(<*) <$> get <*> dropRemainders
@ -72,7 +73,7 @@ getResults connection integerDatetimes decoder =
getPreparedStatementKey ::
LibPQ.Connection -> PreparedStatementRegistry.PreparedStatementRegistry ->
ByteString -> [LibPQ.Oid] ->
IO (Either ResultsDecoders.Error ByteString)
IO (Either CommandError ByteString)
getPreparedStatementKey connection registry template oidList =
{-# SCC "getPreparedStatementKey" #-}
PreparedStatementRegistry.update localKey onNewRemoteKey onOldRemoteKey registry
@ -99,33 +100,50 @@ getPreparedStatementKey connection registry template oidList =
pure (pure key)
{-# INLINE checkedSend #-}
checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either ResultsDecoders.Error ())
checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either CommandError ())
checkedSend connection send =
send >>= \case
False -> fmap (Left . ResultsDecoders.ClientError) $ LibPQ.errorMessage connection
False -> fmap (Left . ClientError) $ LibPQ.errorMessage connection
True -> pure (Right ())
{-# INLINE sendPreparedParametricQuery #-}
sendPreparedParametricQuery ::
LibPQ.Connection ->
PreparedStatementRegistry.PreparedStatementRegistry ->
Bool ->
ByteString ->
[LibPQ.Oid] ->
[Maybe (ByteString, LibPQ.Format)] ->
IO (Either ResultsDecoders.Error ())
sendPreparedParametricQuery connection registry template oidList valueAndFormatList =
runExceptT $ do
key <- ExceptT $ getPreparedStatementKey connection registry template oidList
ExceptT $ checkedSend connection $ LibPQ.sendQueryPrepared connection key valueAndFormatList LibPQ.Binary
ParamsEncoders.Params a ->
a ->
IO (Either CommandError ())
sendPreparedParametricQuery connection registry integerDatetimes template (ParamsEncoders.Params (Op encoderOp)) input =
let
(oidList, valueAndFormatList) =
let
step (oid, format, encoder, _) ~(oidList, bytesAndFormatList) =
(,)
(oid : oidList)
(fmap (\bytes -> (bytes, format)) (encoder integerDatetimes) : bytesAndFormatList)
in foldr step ([], []) (encoderOp input)
in runExceptT $ do
key <- ExceptT $ getPreparedStatementKey connection registry template oidList
ExceptT $ checkedSend connection $ LibPQ.sendQueryPrepared connection key valueAndFormatList LibPQ.Binary
{-# INLINE sendUnpreparedParametricQuery #-}
sendUnpreparedParametricQuery ::
LibPQ.Connection ->
Bool ->
ByteString ->
[Maybe (LibPQ.Oid, ByteString, LibPQ.Format)] ->
IO (Either ResultsDecoders.Error ())
sendUnpreparedParametricQuery connection template paramList =
checkedSend connection $ LibPQ.sendQueryParams connection template paramList LibPQ.Binary
ParamsEncoders.Params a ->
a ->
IO (Either CommandError ())
sendUnpreparedParametricQuery connection integerDatetimes template (ParamsEncoders.Params (Op encoderOp)) input =
let
params =
let
step (oid, format, encoder, _) acc =
((,,) <$> pure oid <*> encoder integerDatetimes <*> pure format) : acc
in foldr step [] (encoderOp input)
in checkedSend connection $ LibPQ.sendQueryParams connection template params LibPQ.Binary
{-# INLINE sendParametricQuery #-}
sendParametricQuery ::
@ -136,24 +154,14 @@ sendParametricQuery ::
ParamsEncoders.Params a ->
Bool ->
a ->
IO (Either ResultsDecoders.Error ())
IO (Either CommandError ())
sendParametricQuery connection integerDatetimes registry template encoder prepared params =
{-# SCC "sendParametricQuery" #-}
if prepared
then
let
(oidList, valueAndFormatList) =
ParamsEncoders.run' encoder params integerDatetimes
in
sendPreparedParametricQuery connection registry template oidList valueAndFormatList
else
let
paramList =
ParamsEncoders.run'' encoder params integerDatetimes
in
sendUnpreparedParametricQuery connection template paramList
then sendPreparedParametricQuery connection registry integerDatetimes template encoder params
else sendUnpreparedParametricQuery connection integerDatetimes template encoder params
{-# INLINE sendNonparametricQuery #-}
sendNonparametricQuery :: LibPQ.Connection -> ByteString -> IO (Either ResultsDecoders.Error ())
sendNonparametricQuery :: LibPQ.Connection -> ByteString -> IO (Either CommandError ())
sendNonparametricQuery connection sql =
checkedSend connection $ LibPQ.sendQuery connection sql

152
library/Hasql/Private/PTI.hs
View File

@ -8,87 +8,87 @@ import qualified Database.PostgreSQL.LibPQ as LibPQ
data PTI = PTI { ptiOID :: !OID, ptiArrayOID :: !(Maybe OID) }
-- | A Word32 and a LibPQ representation of an OID
data OID = OID { oidWord32 :: !Word32, oidPQ :: !LibPQ.Oid }
data OID = OID { oidWord32 :: !Word32, oidPQ :: !LibPQ.Oid, oidFormat :: !LibPQ.Format }
mkOID :: Word32 -> OID
mkOID x =
OID x ((LibPQ.Oid . fromIntegral) x)
mkOID :: LibPQ.Format -> Word32 -> OID
mkOID format x =
OID x ((LibPQ.Oid . fromIntegral) x) format
mkPTI :: Word32 -> Maybe Word32 -> PTI
mkPTI oid arrayOID =
PTI (mkOID oid) (fmap mkOID arrayOID)
mkPTI :: LibPQ.Format -> Word32 -> Maybe Word32 -> PTI
mkPTI format oid arrayOID =
PTI (mkOID format oid) (fmap (mkOID format) arrayOID)
-- * Constants
-------------------------
abstime = mkPTI 702 (Just 1023)
aclitem = mkPTI 1033 (Just 1034)
bit = mkPTI 1560 (Just 1561)
bool = mkPTI 16 (Just 1000)
box = mkPTI 603 (Just 1020)
bpchar = mkPTI 1042 (Just 1014)
bytea = mkPTI 17 (Just 1001)
char = mkPTI 18 (Just 1002)
cid = mkPTI 29 (Just 1012)
cidr = mkPTI 650 (Just 651)
circle = mkPTI 718 (Just 719)
cstring = mkPTI 2275 (Just 1263)
date = mkPTI 1082 (Just 1182)
daterange = mkPTI 3912 (Just 3913)
float4 = mkPTI 700 (Just 1021)
float8 = mkPTI 701 (Just 1022)
gtsvector = mkPTI 3642 (Just 3644)
inet = mkPTI 869 (Just 1041)
int2 = mkPTI 21 (Just 1005)
int2vector = mkPTI 22 (Just 1006)
int4 = mkPTI 23 (Just 1007)
int4range = mkPTI 3904 (Just 3905)
int8 = mkPTI 20 (Just 1016)
int8range = mkPTI 3926 (Just 3927)
interval = mkPTI 1186 (Just 1187)
json = mkPTI 114 (Just 199)
jsonb = mkPTI 3802 (Just 3807)
line = mkPTI 628 (Just 629)
lseg = mkPTI 601 (Just 1018)
macaddr = mkPTI 829 (Just 1040)
money = mkPTI 790 (Just 791)
name = mkPTI 19 (Just 1003)
numeric = mkPTI 1700 (Just 1231)
numrange = mkPTI 3906 (Just 3907)
oid = mkPTI 26 (Just 1028)
oidvector = mkPTI 30 (Just 1013)
path = mkPTI 602 (Just 1019)
point = mkPTI 600 (Just 1017)
polygon = mkPTI 604 (Just 1027)
record = mkPTI 2249 (Just 2287)
refcursor = mkPTI 1790 (Just 2201)
regclass = mkPTI 2205 (Just 2210)
regconfig = mkPTI 3734 (Just 3735)
regdictionary = mkPTI 3769 (Just 3770)
regoper = mkPTI 2203 (Just 2208)
regoperator = mkPTI 2204 (Just 2209)
regproc = mkPTI 24 (Just 1008)
regprocedure = mkPTI 2202 (Just 2207)
regtype = mkPTI 2206 (Just 2211)
reltime = mkPTI 703 (Just 1024)
text = mkPTI 25 (Just 1009)
tid = mkPTI 27 (Just 1010)
time = mkPTI 1083 (Just 1183)
timestamp = mkPTI 1114 (Just 1115)
timestamptz = mkPTI 1184 (Just 1185)
timetz = mkPTI 1266 (Just 1270)
tinterval = mkPTI 704 (Just 1025)
tsquery = mkPTI 3615 (Just 3645)
tsrange = mkPTI 3908 (Just 3909)
tstzrange = mkPTI 3910 (Just 3911)
tsvector = mkPTI 3614 (Just 3643)
txid_snapshot = mkPTI 2970 (Just 2949)
unknown = mkPTI 705 (Just 705)
uuid = mkPTI 2950 (Just 2951)
varbit = mkPTI 1562 (Just 1563)
varchar = mkPTI 1043 (Just 1015)
void = mkPTI 2278 Nothing
xid = mkPTI 28 (Just 1011)
xml = mkPTI 142 (Just 143)
abstime = mkPTI LibPQ.Binary 702 (Just 1023)
aclitem = mkPTI LibPQ.Binary 1033 (Just 1034)
bit = mkPTI LibPQ.Binary 1560 (Just 1561)
bool = mkPTI LibPQ.Binary 16 (Just 1000)
box = mkPTI LibPQ.Binary 603 (Just 1020)
bpchar = mkPTI LibPQ.Binary 1042 (Just 1014)
bytea = mkPTI LibPQ.Binary 17 (Just 1001)
char = mkPTI LibPQ.Binary 18 (Just 1002)
cid = mkPTI LibPQ.Binary 29 (Just 1012)
cidr = mkPTI LibPQ.Binary 650 (Just 651)
circle = mkPTI LibPQ.Binary 718 (Just 719)
cstring = mkPTI LibPQ.Binary 2275 (Just 1263)
date = mkPTI LibPQ.Binary 1082 (Just 1182)
daterange = mkPTI LibPQ.Binary 3912 (Just 3913)
float4 = mkPTI LibPQ.Binary 700 (Just 1021)
float8 = mkPTI LibPQ.Binary 701 (Just 1022)
gtsvector = mkPTI LibPQ.Binary 3642 (Just 3644)
inet = mkPTI LibPQ.Binary 869 (Just 1041)
int2 = mkPTI LibPQ.Binary 21 (Just 1005)
int2vector = mkPTI LibPQ.Binary 22 (Just 1006)
int4 = mkPTI LibPQ.Binary 23 (Just 1007)
int4range = mkPTI LibPQ.Binary 3904 (Just 3905)
int8 = mkPTI LibPQ.Binary 20 (Just 1016)
int8range = mkPTI LibPQ.Binary 3926 (Just 3927)
interval = mkPTI LibPQ.Binary 1186 (Just 1187)
json = mkPTI LibPQ.Binary 114 (Just 199)
jsonb = mkPTI LibPQ.Binary 3802 (Just 3807)
line = mkPTI LibPQ.Binary 628 (Just 629)
lseg = mkPTI LibPQ.Binary 601 (Just 1018)
macaddr = mkPTI LibPQ.Binary 829 (Just 1040)
money = mkPTI LibPQ.Binary 790 (Just 791)
name = mkPTI LibPQ.Binary 19 (Just 1003)
numeric = mkPTI LibPQ.Binary 1700 (Just 1231)
numrange = mkPTI LibPQ.Binary 3906 (Just 3907)
oid = mkPTI LibPQ.Binary 26 (Just 1028)
oidvector = mkPTI LibPQ.Binary 30 (Just 1013)
path = mkPTI LibPQ.Binary 602 (Just 1019)
point = mkPTI LibPQ.Binary 600 (Just 1017)
polygon = mkPTI LibPQ.Binary 604 (Just 1027)
record = mkPTI LibPQ.Binary 2249 (Just 2287)
refcursor = mkPTI LibPQ.Binary 1790 (Just 2201)
regclass = mkPTI LibPQ.Binary 2205 (Just 2210)
regconfig = mkPTI LibPQ.Binary 3734 (Just 3735)
regdictionary = mkPTI LibPQ.Binary 3769 (Just 3770)
regoper = mkPTI LibPQ.Binary 2203 (Just 2208)
regoperator = mkPTI LibPQ.Binary 2204 (Just 2209)
regproc = mkPTI LibPQ.Binary 24 (Just 1008)
regprocedure = mkPTI LibPQ.Binary 2202 (Just 2207)
regtype = mkPTI LibPQ.Binary 2206 (Just 2211)
reltime = mkPTI LibPQ.Binary 703 (Just 1024)
text = mkPTI LibPQ.Binary 25 (Just 1009)
tid = mkPTI LibPQ.Binary 27 (Just 1010)
time = mkPTI LibPQ.Binary 1083 (Just 1183)
timestamp = mkPTI LibPQ.Binary 1114 (Just 1115)
timestamptz = mkPTI LibPQ.Binary 1184 (Just 1185)
timetz = mkPTI LibPQ.Binary 1266 (Just 1270)
tinterval = mkPTI LibPQ.Binary 704 (Just 1025)
tsquery = mkPTI LibPQ.Binary 3615 (Just 3645)
tsrange = mkPTI LibPQ.Binary 3908 (Just 3909)
tstzrange = mkPTI LibPQ.Binary 3910 (Just 3911)
tsvector = mkPTI LibPQ.Binary 3614 (Just 3643)
txid_snapshot = mkPTI LibPQ.Binary 2970 (Just 2949)
unknown = mkPTI LibPQ.Text 705 (Just 705)
uuid = mkPTI LibPQ.Binary 2950 (Just 2951)
varbit = mkPTI LibPQ.Binary 1562 (Just 1563)
varchar = mkPTI LibPQ.Binary 1043 (Just 1015)
void = mkPTI LibPQ.Binary 2278 Nothing
xid = mkPTI LibPQ.Binary 28 (Just 1011)
xml = mkPTI LibPQ.Binary 142 (Just 143)

61
library/Hasql/Private/Query.hs
View File

@ -1,61 +0,0 @@
module Hasql.Private.Query
where
import Hasql.Private.Prelude
import qualified Database.PostgreSQL.LibPQ as LibPQ
import qualified Hasql.Private.IO as IO
import qualified Hasql.Private.Connection as Connection
import qualified Hasql.Private.Decoders.Results as Decoders.Results
import qualified Hasql.Private.Encoders.Params as Encoders.Params
-- |
-- An abstraction over parametric queries.
--
-- It is composable using
-- the standard interfaces of the category theory,
-- which it has instances of.
-- E.g., here's how you can compose queries
-- using the Arrow notation:
--
-- @
-- -- |
-- -- Given an Update query,
-- -- which uses the \@fmap (> 0) 'Decoders.Results.rowsAffected'\@ decoder
-- -- to detect, whether it had any effect,
-- -- and an Insert query,
-- -- produces a query which performs Upsert.
-- composeUpsert :: Query a Bool -> Query a () -> Query a ()
-- composeUpsert update insert =
-- proc params -> do
-- updated <- update -< params
-- if updated
-- then 'returnA' -< ()
-- else insert -< params
-- @
newtype Query a b =
Query (Kleisli (ReaderT Connection.Connection (ExceptT Decoders.Results.Error IO)) a b)
deriving (Category, Arrow, ArrowChoice, ArrowLoop, ArrowApply)
instance Functor (Query a) where
{-# INLINE fmap #-}
fmap =
(^<<)
instance Profunctor Query where
{-# INLINE lmap #-}
lmap =
(^>>)
{-# INLINE rmap #-}
rmap =
(^<<)
statement :: ByteString -> Encoders.Params.Params a -> Decoders.Results.Results b -> Bool -> Query a b
statement template encoder decoder preparable =
Query $ Kleisli $ \params ->
ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) ->
ExceptT $ withMVar pqConnectionRef $ \pqConnection -> do
r1 <- IO.sendParametricQuery pqConnection integerDatetimes registry template encoder preparable params
r2 <- IO.getResults pqConnection integerDatetimes decoder
return $ r1 *> r2

102
library/Hasql/Private/Session.hs
View File

@ -2,24 +2,26 @@ module Hasql.Private.Session
where
import Hasql.Private.Prelude
import Hasql.Private.Errors
import qualified Database.PostgreSQL.LibPQ as LibPQ
import qualified Hasql.Private.Decoders.Results as Decoders.Results
import qualified Hasql.Private.Decoders.Result as Decoders.Result
import qualified Hasql.Private.Encoders.Params as Encoders.Params
import qualified Hasql.Private.Settings as Settings
import qualified Hasql.Private.IO as IO
import qualified Hasql.Private.Query as Query
import qualified Hasql.Query as Query
import qualified Hasql.Private.Connection as Connection
-- |
-- A batch of actions to be executed in the context of a database connection.
newtype Session a =
Session (ReaderT Connection.Connection (ExceptT Error IO) a)
deriving (Functor, Applicative, Monad, MonadError Error, MonadIO)
Session (ReaderT Connection.Connection (ExceptT QueryError IO) a)
deriving (Functor, Applicative, Monad, MonadError QueryError, MonadIO)
-- |
-- Executes a bunch of commands on the provided connection.
run :: Session a -> Connection.Connection -> IO (Either Error a)
run :: Session a -> Connection.Connection -> IO (Either QueryError a)
run (Session impl) connection =
runExceptT $
runReaderT impl connection
@ -31,87 +33,27 @@ run (Session impl) connection =
sql :: ByteString -> Session ()
sql sql =
Session $ ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) ->
ExceptT $ fmap (mapLeft unsafeCoerce) $ withMVar pqConnectionRef $ \pqConnection -> do
ExceptT $ fmap (mapLeft (QueryError sql [])) $ withMVar pqConnectionRef $ \pqConnection -> do
r1 <- IO.sendNonparametricQuery pqConnection sql
r2 <- IO.getResults pqConnection integerDatetimes decoder
return $ r1 *> r2
where
decoder =
Decoders.Results.single $
Decoders.Result.unit
Decoders.Results.single Decoders.Result.unit
-- |
-- Parameters and a specification of the parametric query to apply them to.
query :: a -> Query.Query a b -> Session b
query input (Query.Query (Kleisli impl)) =
Session $ unsafeCoerce $ impl input
-- * Error
-------------------------
-- |
-- An error of some command in the session.
data Error =
-- |
-- An error on the client-side,
-- with a message generated by the \"libpq\" library.
-- Usually indicates problems with connection.
ClientError !(Maybe ByteString) |
-- |
-- Some error with a command result.
ResultError !ResultError
deriving (Show, Eq)
-- |
-- An error with a command result.
data ResultError =
-- |
-- An error reported by the DB.
-- Consists of the following: Code, message, details, hint.
--
-- * __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.
--
-- * __Message__.
-- The primary human-readable error message (typically one line). Always present.
--
-- * __Details__.
-- An optional secondary error message carrying more detail about the problem.
-- Might run to multiple lines.
--
-- * __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.
ServerError !ByteString !ByteString !(Maybe ByteString) !(Maybe ByteString) |
-- |
-- The database returned an unexpected result.
-- Indicates an improper statement or a schema mismatch.
UnexpectedResult !Text |
-- |
-- An error of the row reader, preceded by the index of the row.
RowError !Int !RowError |
-- |
-- An unexpected amount of rows.
UnexpectedAmountOfRows !Int
deriving (Show, Eq)
-- |
-- An error during the decoding of a specific row.
data RowError =
-- |
-- Appears on the attempt to parse more columns than there are in the result.
EndOfInput |
-- |
-- Appears on the attempt to parse a @NULL@ as some value.
UnexpectedNull |
-- |
-- Appears when a wrong value parser is used.
-- Comes with the error details.
ValueError !Text
deriving (Show, Eq)
query :: params -> Query.Query params result -> Session result
query input (Query.Query template encoder decoder preparable) =
Session $ ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) ->
ExceptT $ fmap (mapLeft (QueryError template inputReps)) $ withMVar pqConnectionRef $ \pqConnection -> do
r1 <- IO.sendParametricQuery pqConnection integerDatetimes registry template (unsafeCoerce encoder) preparable input
r2 <- IO.getResults pqConnection integerDatetimes (unsafeCoerce decoder)
return $ r1 *> r2
where
inputReps =
let
Encoders.Params.Params (Op encoderOp) = (unsafeCoerce encoder)
step (_, _, _, rendering) acc =
rendering : acc
in foldr step [] (encoderOp input)

26
library/Hasql/Query.hs
View File

@ -1,19 +1,11 @@
module Hasql.Query
(
Query.Query,
statement,
)
where
import Hasql.Private.Prelude
import qualified Hasql.Private.Query as Query
import qualified Hasql.Private.Decoders.Results as Decoders.Results
import qualified Hasql.Decoders as Decoders
import qualified Hasql.Private.Encoders.Params as Encoders.Params
import qualified Hasql.Encoders as Encoders
-- |
-- A specification of a strictly single-statement query, which can be parameterized and prepared.
--
@ -34,9 +26,9 @@ import qualified Hasql.Encoders as Encoders
-- Following is an example of the declaration of a prepared statement with its associated codecs.
--
-- @
-- selectSum :: Hasql.Query.'Query.Query' (Int64, Int64) Int64
-- selectSum :: Hasql.Query.'Query' (Int64, Int64) Int64
-- selectSum =
-- Hasql.Query.'statement' sql encoder decoder True
-- Hasql.Query.'Query' sql encoder decoder True
-- where
-- sql =
-- "select ($1 + $2)"
@ -50,8 +42,14 @@ import qualified Hasql.Encoders as Encoders
-- The statement above accepts a product of two parameters of type 'Int64'
-- and produces a single result of type 'Int64'.
--
{-# INLINE statement #-}
statement :: ByteString -> Encoders.Params a -> Decoders.Result b -> Bool -> Query.Query a b
statement =
unsafeCoerce Query.statement
data Query a b =
Query ByteString (Encoders.Params a) (Decoders.Result b) Bool
instance Functor (Query a) where
{-# INLINE fmap #-}
fmap = rmap
instance Profunctor Query where
{-# INLINE dimap #-}
dimap f1 f2 (Query template encoder decoder preparable) =
Query template (contramap f1 encoder) (fmap f2 decoder) preparable

17
library/Hasql/Session.hs
View File

@ -1,15 +1,14 @@
module Hasql.Session
(
Session.Session,
Session.sql,
Session.query,
Session,
sql,
query,
-- * Execution
Session.Error(..),
Session.ResultError(..),
Session.RowError(..),
Session.run,
run,
-- * Errors
module Hasql.Private.Errors,
)
where
import qualified Hasql.Private.Session as Session
import Hasql.Private.Session
import Hasql.Private.Errors

4
profiling/Main.hs
View File

@ -60,7 +60,7 @@ queryWithManyParameters =
queryWithSingleRow :: C.Query () (Int64, Int64)
queryWithSingleRow =
C.statement template encoder decoder True
C.Query template encoder decoder True
where
template =
"SELECT 1, 2"
@ -77,7 +77,7 @@ queryWithSingleRow =
queryWithManyRows :: (D.Row (Int64, Int64) -> D.Result result) -> C.Query () result
queryWithManyRows decoder =
C.statement template encoder (decoder rowDecoder) True
C.Query template encoder (decoder rowDecoder) True
where
template =
"SELECT generate_series(0,1000) as a, generate_series(1000,2000) as b"

73
tasty/Main.hs
View File

@ -22,10 +22,29 @@ tree =
localOption (NumThreads 1) $
testGroup "All tests"
[
testCase "Failed query" $
let
query =
Query.Query "select true where 1 = any ($1) and $2" encoder decoder True
where
encoder =
contrazip2
(Encoders.value (Encoders.array (Encoders.arrayDimension foldl' (Encoders.arrayValue Encoders.int8))))
(Encoders.value Encoders.text)
decoder =
fmap (maybe False (const True)) (Decoders.maybeRow (Decoders.value Decoders.bool))
session =
Session.query ([3, 7], "a") query
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
query =
Query.statement "select true where 1 = any ($1)" encoder decoder True
Query.Query "select true where 1 = any ($1)" encoder decoder True
where
encoder =
Encoders.value (Encoders.array (Encoders.arrayDimension foldl' (Encoders.arrayValue Encoders.int8)))
@ -43,7 +62,7 @@ tree =
testCase "NOT IN simulation" $
let
query =
Query.statement "select true where 3 <> all ($1)" encoder decoder True
Query.Query "select true where 3 <> all ($1)" encoder decoder True
where
encoder =
Encoders.value (Encoders.array (Encoders.arrayDimension foldl' (Encoders.arrayValue Encoders.int8)))
@ -61,7 +80,7 @@ tree =
testCase "Composite decoding" $
let
query =
Query.statement sql encoder decoder True
Query.Query sql encoder decoder True
where
sql =
"select (1, true)"
@ -78,7 +97,7 @@ tree =
testCase "Complex composite decoding" $
let
query =
Query.statement sql encoder decoder True
Query.Query sql encoder decoder True
where
sql =
"select (1, true) as entity1, ('hello', 3) as entity2"
@ -111,7 +130,7 @@ tree =
Session.query () query
where
query =
Query.statement sql encoder decoder True
Query.Query sql encoder decoder True
where
sql =
"select array[]::int8[]"
@ -129,7 +148,7 @@ tree =
where
resultTest =
\case
Right (Left (Session.ResultError (Session.ServerError "26000" _ _ _))) -> False
Right (Left (Session.QueryError _ _ (Session.ResultError (Session.ServerError "26000" _ _ _)))) -> False
_ -> True
session =
catchError session (const (pure ())) *> session
@ -138,7 +157,7 @@ tree =
Session.query () query
where
query =
Query.statement sql encoder decoder True
Query.Query sql encoder decoder True
where
sql =
"absurd"
@ -161,7 +180,7 @@ tree =
Session.query 1 query
where
query =
Query.statement sql encoder decoder True
Query.Query sql encoder decoder True
where
sql =
"select $1 :: int8"
@ -177,7 +196,7 @@ tree =
let
sumQuery :: Query.Query (Int64, Int64) Int64
sumQuery =
Query.statement sql encoder decoder True
Query.Query sql encoder decoder True
where
sql =
"select ($1 + $2)"
@ -202,7 +221,7 @@ tree =
let
sumQuery :: Query.Query (Int64, Int64) Int64
sumQuery =
Query.statement sql encoder decoder True
Query.Query sql encoder decoder True
where
sql =
"select ($1 + $2)"
@ -229,7 +248,7 @@ tree =
DSL.session $ do
let
query =
Query.statement sql encoder decoder True
Query.Query sql encoder decoder True
where
sql =
"select $1 = interval '10 seconds'"
@ -246,7 +265,7 @@ tree =
DSL.session $ do
let
query =
Query.statement sql encoder decoder True
Query.Query sql encoder decoder True
where
sql =
"select interval '10 seconds'"
@ -263,7 +282,7 @@ tree =
DSL.session $ do
let
query =
Query.statement sql encoder decoder True
Query.Query sql encoder decoder True
where
sql =
"select $1"
@ -280,21 +299,21 @@ tree =
DSL.session $ do
let
query =
Query.statement sql mempty Decoders.unit True
Query.Query sql mempty Decoders.unit True
where
sql =
"drop type if exists mood"
in DSL.query () query
let
query =
Query.statement sql mempty Decoders.unit True
Query.Query sql mempty Decoders.unit True
where
sql =
"create type mood as enum ('sad', 'ok', 'happy')"
in DSL.query () query
let
query =
Query.statement sql encoder decoder True
Query.Query sql encoder decoder True
where
sql =
"select $1 = ('ok' :: mood)"
@ -311,21 +330,21 @@ tree =
DSL.session $ do
let
query =
Query.statement sql mempty Decoders.unit True
Query.Query sql mempty Decoders.unit True
where
sql =
"create or replace function overloaded(a int, b int) returns int as $$ select a + b $$ language sql;"
in DSL.query () query
let
query =
Query.statement sql mempty Decoders.unit True
Query.Query sql mempty Decoders.unit 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.query () query
let
query =
Query.statement sql encoder decoder True
Query.Query sql encoder decoder True
where
sql =
"select overloaded($1, $2) || overloaded($3, $4, $5)"
@ -342,21 +361,21 @@ tree =
DSL.session $ do
let
query =
Query.statement sql mempty Decoders.unit True
Query.Query sql mempty Decoders.unit True
where
sql =
"drop type if exists mood"
in DSL.query () query
let
query =
Query.statement sql mempty Decoders.unit True
Query.Query sql mempty Decoders.unit True
where
sql =
"create type mood as enum ('sad', 'ok', 'happy')"
in DSL.query () query
let
query =
Query.statement sql encoder decoder True
Query.Query sql encoder decoder True
where
sql =
"select ($1 :: mood)"
@ -376,7 +395,7 @@ tree =
DSL.query "ok" query
where
query =
Query.statement sql encoder decoder True
Query.Query sql encoder decoder True
where
sql =
"select $1"
@ -388,7 +407,7 @@ tree =
DSL.query 1 query
where
query =
Query.statement sql encoder decoder True
Query.Query sql encoder decoder True
where
sql =
"select $1"
@ -419,7 +438,7 @@ tree =
DSL.query () $ Queries.plain $
"insert into a (name) values ('a')"
deleteRows =
DSL.query () $ Query.statement sql def decoder False
DSL.query () $ Query.Query sql def decoder False
where
sql =
"delete from a"
@ -433,8 +452,8 @@ tree =
DSL.session $ do
DSL.query () $ Queries.plain $ "drop table if exists a"
DSL.query () $ Queries.plain $ "create table a (id serial not null, v char not null, primary key (id))"
id1 <- DSL.query () $ Query.statement "insert into a (v) values ('a') returning id" def (Decoders.singleRow (Decoders.value Decoders.int4)) False
id2 <- DSL.query () $ Query.statement "insert into a (v) values ('b') returning id" def (Decoders.singleRow (Decoders.value Decoders.int4)) False
id1 <- DSL.query () $ Query.Query "insert into a (v) values ('a') returning id" def (Decoders.singleRow (Decoders.value Decoders.int4)) False
id2 <- DSL.query () $ Query.Query "insert into a (v) values ('b') returning id" def (Decoders.singleRow (Decoders.value Decoders.int4)) False
DSL.query () $ Queries.plain $ "drop table if exists a"
pure (id1, id2)
in assertEqual "" (Right (1, 2)) =<< actualIO

2
tasty/Main/DSL.hs
View File

@ -21,7 +21,7 @@ type Session =
data SessionError =
ConnectionError (HC.ConnectionError) |
SessionError (Hasql.Session.Error)
SessionError (Hasql.Session.QueryError)
deriving (Show, Eq)
session :: Session a -> IO (Either SessionError a)

6
tasty/Main/Queries.hs
View File

@ -9,11 +9,11 @@ import qualified Main.Prelude as Prelude
def :: ByteString -> HQ.Query () ()
def sql =
HQ.statement sql Prelude.def Prelude.def False
HQ.Query sql Prelude.def Prelude.def False
plain :: ByteString -> HQ.Query () ()
plain sql =
HQ.statement sql mempty HD.unit False
HQ.Query sql mempty HD.unit False
dropType :: ByteString -> HQ.Query () ()
dropType name =
@ -28,7 +28,7 @@ createEnum name values =
selectList :: HQ.Query () ([] (Int64, Int64))
selectList =
HQ.statement sql mempty decoder True
HQ.Query sql mempty decoder True
where
sql =
"values (1,2), (3,4), (5,6)"

2
threads-test/Main/Queries.hs
View File

@ -8,7 +8,7 @@ import qualified Hasql.Decoders as D
selectSleep :: Query Double ()
selectSleep =
statement sql encoder decoder True
Query sql encoder decoder True
where
sql =
"select pg_sleep($1)"