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

Format with ormolu

Browse Source
This commit is contained in:
Nikita Volkov 2022-06-20 13:54:54 +03:00
parent e2852d42fb
commit b64a7015a1
34 changed files with 1670 additions and 1818 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
benchmarks/Main.hs
View File

@ -1,15 +1,14 @@
module Main where
import Prelude
import qualified Data.Vector as F
import Gauge
import Gauge.Main
import qualified Hasql.Connection as A
import qualified Hasql.Session as B
import qualified Hasql.Statement as C
import qualified Hasql.Decoders as D
import qualified Hasql.Encoders as E
import qualified Data.Vector as F
import qualified Hasql.Session as B
import qualified Hasql.Statement as C
import Prelude
main =
do
@ -20,22 +19,18 @@ main =
A.acquire ""
useConnection connection =
defaultMain
[
sessionBench "largeResultInVector" sessionWithSingleLargeResultInVector
,
sessionBench "largeResultInList" sessionWithSingleLargeResultInList
,
sessionBench "manyLargeResults" sessionWithManyLargeResults
,
sessionBench "manySmallResults" sessionWithManySmallResults
]
[ sessionBench "largeResultInVector" sessionWithSingleLargeResultInVector,
sessionBench "largeResultInList" sessionWithSingleLargeResultInList,
sessionBench "manyLargeResults" sessionWithManyLargeResults,
sessionBench "manySmallResults" sessionWithManySmallResults
]
where
sessionBench :: NFData a => String -> B.Session a -> Benchmark
sessionBench name session =
bench name (nfIO (fmap (either (error "") id) (B.run session connection)))
-- * Sessions
-------------------------
sessionWithManySmallParameters :: Vector (Int64, Int64) -> B.Session ()
@ -58,8 +53,8 @@ sessionWithManySmallResults :: B.Session [(Int64, Int64)]
sessionWithManySmallResults =
replicateM 1000 (B.statement () statementWithSingleRow)
-- * Statements
-------------------------
statementWithManyParameters :: C.Statement (Vector (Int64, Int64)) ()

17
library/Hasql/Connection.hs
View File

@ -1,15 +1,14 @@
-- |
-- This module provides a low-level effectful API dealing with the connections to the database.
module Hasql.Connection
(
Connection,
ConnectionError(..),
acquire,
release,
Settings,
settings,
withLibPQConnection
)
( Connection,
ConnectionError (..),
acquire,
release,
Settings,
settings,
withLibPQConnection,
)
where
import Hasql.Private.Connection

131
library/Hasql/Decoders.hs
View File

@ -1,67 +1,72 @@
{-|
A DSL for declaration of result decoders.
-}
-- |
-- A DSL for declaration of result decoders.
module Hasql.Decoders
(
-- * Result
Result,
noResult,
rowsAffected,
singleRow,
-- ** Specialized multi-row results
rowMaybe,
rowVector,
rowList,
-- ** Multi-row traversers
foldlRows,
foldrRows,
-- * Row
Row,
column,
-- * Nullability
NullableOrNot,
nonNullable,
nullable,
-- * Value
Value,
bool,
int2,
int4,
int8,
float4,
float8,
numeric,
char,
text,
bytea,
date,
timestamp,
timestamptz,
time,
timetz,
interval,
uuid,
inet,
json,
jsonBytes,
jsonb,
jsonbBytes,
array,
listArray,
vectorArray,
composite,
hstore,
enum,
custom,
refine,
-- * Array
Array,
dimension,
element,
-- * Composite
Composite,
field,
)
( -- * Result
Result,
noResult,
rowsAffected,
singleRow,
-- ** Specialized multi-row results
rowMaybe,
rowVector,
rowList,
-- ** Multi-row traversers
foldlRows,
foldrRows,
-- * Row
Row,
column,
-- * Nullability
NullableOrNot,
nonNullable,
nullable,
-- * Value
Value,
bool,
int2,
int4,
int8,
float4,
float8,
numeric,
char,
text,
bytea,
date,
timestamp,
timestamptz,
time,
timetz,
interval,
uuid,
inet,
json,
jsonBytes,
jsonb,
jsonbBytes,
array,
listArray,
vectorArray,
composite,
hstore,
enum,
custom,
refine,
-- * Array
Array,
dimension,
element,
-- * Composite
Composite,
field,
)
where
import Hasql.Private.Decoders

97
library/Hasql/Encoders.hs
View File

@ -1,52 +1,53 @@
{-|
A DSL for declaration of statement parameter encoders.
For compactness of names all the types defined here imply being an encoder.
E.g., the `Array` type is an __encoder__ of arrays, not the data-structure itself.
-}
-- |
-- A DSL for declaration of statement parameter encoders.
--
-- For compactness of names all the types defined here imply being an encoder.
-- E.g., the `Array` type is an __encoder__ of arrays, not the data-structure itself.
module Hasql.Encoders
(
-- * Parameters product
Params,
noParams,
param,
-- * Nullability
NullableOrNot,
nonNullable,
nullable,
-- * Value
Value,
bool,
int2,
int4,
int8,
float4,
float8,
numeric,
char,
text,
bytea,
date,
timestamp,
timestamptz,
time,
timetz,
interval,
uuid,
inet,
json,
jsonBytes,
jsonb,
jsonbBytes,
enum,
unknown,
array,
foldableArray,
-- * Array
Array,
element,
dimension,
)
( -- * Parameters product
Params,
noParams,
param,
-- * Nullability
NullableOrNot,
nonNullable,
nullable,
-- * Value
Value,
bool,
int2,
int4,
int8,
float4,
float8,
numeric,
char,
text,
bytea,
date,
timestamp,
timestamptz,
time,
timetz,
interval,
uuid,
inet,
json,
jsonBytes,
jsonb,
jsonbBytes,
enum,
unknown,
array,
foldableArray,
-- * Array
Array,
element,
dimension,
)
where
import Hasql.Private.Encoders

18
library/Hasql/Private/Commands.hs
View File

@ -1,20 +1,18 @@
module Hasql.Private.Commands
(
Commands,
asBytes,
setEncodersToUTF8,
setMinClientMessagesToWarning,
)
( Commands,
asBytes,
setEncodersToUTF8,
setMinClientMessagesToWarning,
)
where
import Hasql.Private.Prelude
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as BL
import Hasql.Private.Prelude
newtype Commands =
Commands (DList BB.Builder)
newtype Commands
= Commands (DList BB.Builder)
deriving (Semigroup, Monoid)
asBytes :: Commands -> ByteString

12
library/Hasql/Private/Connection.hs
View File

@ -1,19 +1,17 @@
-- |
-- This module provides a low-level effectful API dealing with the connections to the database.
module Hasql.Private.Connection
where
module Hasql.Private.Connection where
import Hasql.Private.Prelude
import qualified Database.PostgreSQL.LibPQ as LibPQ
import qualified Hasql.Private.PreparedStatementRegistry as PreparedStatementRegistry
import qualified Hasql.Private.IO as IO
import Hasql.Private.Prelude
import qualified Hasql.Private.PreparedStatementRegistry as PreparedStatementRegistry
import qualified Hasql.Private.Settings as Settings
-- |
-- A single connection to the database.
data Connection =
Connection !(MVar LibPQ.Connection) !Bool !PreparedStatementRegistry.PreparedStatementRegistry
data Connection
= Connection !(MVar LibPQ.Connection) !Bool !PreparedStatementRegistry.PreparedStatementRegistry
-- |
-- Possible details of the connection acquistion error.

516
library/Hasql/Private/Decoders.hs
View File

@ -1,53 +1,48 @@
{-|
A DSL for declaration of result decoders.
-}
module Hasql.Private.Decoders
where
-- |
-- A DSL for declaration of result decoders.
module Hasql.Private.Decoders where
import Hasql.Private.Prelude hiding (maybe, bool)
import qualified Data.Vector as Vector
import qualified PostgreSQL.Binary.Decoding as A
import qualified PostgreSQL.Binary.Data as B
import qualified Hasql.Private.Decoders.Results as Results
import qualified Hasql.Private.Decoders.Result as Result
import qualified Hasql.Private.Decoders.Row as Row
import qualified Hasql.Private.Decoders.Value as Value
import qualified Data.Vector.Generic as GenericVector
import qualified Hasql.Private.Decoders.Array as Array
import qualified Hasql.Private.Decoders.Composite as Composite
import qualified Hasql.Private.Decoders.Result as Result
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 Data.Vector.Generic as GenericVector
import qualified PostgreSQL.Binary.Data as B
import qualified PostgreSQL.Binary.Decoding as A
-- * Result
-------------------------
{-|
Decoder of a query result.
-}
-- |
-- Decoder of a query result.
newtype Result a = Result (Results.Results a) deriving (Functor)
{-|
Decode no value from the result.
Useful for statements like @INSERT@ or @CREATE@.
-}
{-# INLINABLE noResult #-}
-- |
-- Decode no value from the result.
--
-- Useful for statements like @INSERT@ or @CREATE@.
{-# INLINEABLE noResult #-}
noResult :: Result ()
noResult = Result (Results.single Result.noResult)
{-|
Get the amount of rows affected by such statements as
@UPDATE@ or @DELETE@.
-}
{-# INLINABLE rowsAffected #-}
-- |
-- Get the amount of rows affected by such statements as
-- @UPDATE@ or @DELETE@.
{-# INLINEABLE rowsAffected #-}
rowsAffected :: Result Int64
rowsAffected = Result (Results.single Result.rowsAffected)
{-|
Exactly one row.
Will raise the 'Errors.UnexpectedAmountOfRows' error if it's any other.
-}
{-# INLINABLE singleRow #-}
-- |
-- Exactly one row.
-- Will raise the 'Errors.UnexpectedAmountOfRows' error if it's any other.
{-# INLINEABLE singleRow #-}
singleRow :: Row a -> Result a
singleRow (Row row) = Result (Results.single (Result.single row))
@ -55,418 +50,375 @@ refineResult :: (a -> Either Text b) -> Result a -> Result b
refineResult refiner (Result results) = Result (Results.refine refiner results)
-- ** Multi-row traversers
-------------------------
{-|
Foldl multiple rows.
-}
{-# INLINABLE foldlRows #-}
-- |
-- Foldl multiple rows.
{-# INLINEABLE foldlRows #-}
foldlRows :: (a -> b -> a) -> a -> Row b -> Result a
foldlRows step init (Row row) = Result (Results.single (Result.foldl step init row))
{-|
Foldr multiple rows.
-}
{-# INLINABLE foldrRows #-}
-- |
-- Foldr multiple rows.
{-# INLINEABLE foldrRows #-}
foldrRows :: (b -> a -> a) -> a -> Row b -> Result a
foldrRows step init (Row row) = Result (Results.single (Result.foldr step init row))
-- ** Specialized multi-row results
-------------------------
{-|
Maybe one row or none.
-}
{-# INLINABLE rowMaybe #-}
-- |
-- Maybe one row or none.
{-# INLINEABLE rowMaybe #-}
rowMaybe :: Row a -> Result (Maybe a)
rowMaybe (Row row) = Result (Results.single (Result.maybe row))
{-|
Zero or more rows packed into the vector.
It's recommended to prefer this function to 'rowList',
since it performs notably better.
-}
{-# INLINABLE rowVector #-}
-- |
-- Zero or more rows packed into the vector.
--
-- It's recommended to prefer this function to 'rowList',
-- since it performs notably better.
{-# INLINEABLE rowVector #-}
rowVector :: Row a -> Result (Vector a)
rowVector (Row row) = Result (Results.single (Result.vector row))
{-|
Zero or more rows packed into the list.
-}
{-# INLINABLE rowList #-}
-- |
-- Zero or more rows packed into the list.
{-# INLINEABLE rowList #-}
rowList :: Row a -> Result [a]
rowList = foldrRows strictCons []
-- * Row
-------------------------
{-|
Decoder of an individual row,
which gets composed of column value decoders.
E.g.:
@
x :: 'Row' (Maybe Int64, Text, TimeOfDay)
x = (,,) '<$>' ('column' . 'nullable') 'int8' '<*>' ('column' . 'nonNullable') 'text' '<*>' ('column' . 'nonNullable') 'time'
@
-}
-- |
-- Decoder of an individual row,
-- which gets composed of column value decoders.
--
-- E.g.:
--
-- @
-- x :: 'Row' (Maybe Int64, Text, TimeOfDay)
-- x = (,,) '<$>' ('column' . 'nullable') 'int8' '<*>' ('column' . 'nonNullable') 'text' '<*>' ('column' . 'nonNullable') 'time'
-- @
newtype Row a = Row (Row.Row a)
deriving (Functor, Applicative, Monad, MonadFail)
{-|
Lift an individual value decoder to a composable row decoder.
-}
{-# INLINABLE column #-}
-- |
-- Lift an individual value decoder to a composable row decoder.
{-# INLINEABLE column #-}
column :: NullableOrNot Value a -> Row a
column = \ case
column = \case
NonNullable (Value imp) -> Row (Row.nonNullValue imp)
Nullable (Value imp) -> Row (Row.value imp)
-- * Nullability
-------------------------
{-|
Extensional specification of nullability over a generic decoder.
-}
-- |
-- Extensional specification of nullability over a generic decoder.
data NullableOrNot decoder a where
NonNullable :: decoder a -> NullableOrNot decoder a
Nullable :: decoder a -> NullableOrNot decoder (Maybe a)
{-|
Specify that a decoder produces a non-nullable value.
-}
-- |
-- Specify that a decoder produces a non-nullable value.
nonNullable :: decoder a -> NullableOrNot decoder a
nonNullable = NonNullable
{-|
Specify that a decoder produces a nullable value.
-}
-- |
-- Specify that a decoder produces a nullable value.
nullable :: decoder a -> NullableOrNot decoder (Maybe a)
nullable = Nullable
-- * Value
-------------------------
{-|
Decoder of a value.
-}
-- |
-- Decoder of a value.
newtype Value a = Value (Value.Value a)
deriving (Functor)
type role Value representational
{-|
Decoder of the @BOOL@ values.
-}
{-# INLINABLE bool #-}
-- |
-- Decoder of the @BOOL@ values.
{-# INLINEABLE bool #-}
bool :: Value Bool
bool = Value (Value.decoder (const A.bool))
{-|
Decoder of the @INT2@ values.
-}
{-# INLINABLE int2 #-}
-- |
-- Decoder of the @INT2@ values.
{-# INLINEABLE int2 #-}
int2 :: Value Int16
int2 = Value (Value.decoder (const A.int))
{-|
Decoder of the @INT4@ values.
-}
{-# INLINABLE int4 #-}
-- |
-- Decoder of the @INT4@ values.
{-# INLINEABLE int4 #-}
int4 :: Value Int32
int4 = Value (Value.decoder (const A.int))
{-|
Decoder of the @INT8@ values.
-}
{-# INLINABLE int8 #-}
-- |
-- Decoder of the @INT8@ values.
{-# INLINEABLE int8 #-}
int8 :: Value Int64
int8 = {-# SCC "int8" #-}
int8 =
{-# SCC "int8" #-}
Value (Value.decoder (const ({-# SCC "int8.int" #-} A.int)))
{-|
Decoder of the @FLOAT4@ values.
-}
{-# INLINABLE float4 #-}
-- |
-- Decoder of the @FLOAT4@ values.
{-# INLINEABLE float4 #-}
float4 :: Value Float
float4 = Value (Value.decoder (const A.float4))
{-|
Decoder of the @FLOAT8@ values.
-}
{-# INLINABLE float8 #-}
-- |
-- Decoder of the @FLOAT8@ values.
{-# INLINEABLE float8 #-}
float8 :: Value Double
float8 = Value (Value.decoder (const A.float8))
{-|
Decoder of the @NUMERIC@ values.
-}
{-# INLINABLE numeric #-}
-- |
-- Decoder of the @NUMERIC@ values.
{-# INLINEABLE numeric #-}
numeric :: Value B.Scientific
numeric = Value (Value.decoder (const A.numeric))
{-|
Decoder of the @CHAR@ values.
Note that it supports Unicode values.
-}
{-# INLINABLE char #-}
-- |
-- Decoder of the @CHAR@ values.
-- Note that it supports Unicode values.
{-# INLINEABLE char #-}
char :: Value Char
char = Value (Value.decoder (const A.char))
{-|
Decoder of the @TEXT@ values.
-}
{-# INLINABLE text #-}
-- |
-- Decoder of the @TEXT@ values.
{-# INLINEABLE text #-}
text :: Value Text
text = Value (Value.decoder (const A.text_strict))
{-|
Decoder of the @BYTEA@ values.
-}
{-# INLINABLE bytea #-}
-- |
-- Decoder of the @BYTEA@ values.
{-# INLINEABLE bytea #-}
bytea :: Value ByteString
bytea = Value (Value.decoder (const A.bytea_strict))
{-|
Decoder of the @DATE@ values.
-}
{-# INLINABLE date #-}
-- |
-- Decoder of the @DATE@ values.
{-# INLINEABLE date #-}
date :: Value B.Day
date = Value (Value.decoder (const A.date))
{-|
Decoder of the @TIMESTAMP@ values.
-}
{-# INLINABLE timestamp #-}
-- |
-- Decoder of the @TIMESTAMP@ values.
{-# INLINEABLE timestamp #-}
timestamp :: Value B.LocalTime
timestamp = Value (Value.decoder (Prelude.bool A.timestamp_float A.timestamp_int))
{-|
Decoder of the @TIMESTAMPTZ@ values.
/NOTICE/
Postgres does not store the timezone information of @TIMESTAMPTZ@.
Instead it stores a UTC value and performs silent conversions
to the currently set timezone, when dealt with in the text format.
However this library bypasses the silent conversions
and communicates with Postgres using the UTC values directly.
-}
{-# INLINABLE timestamptz #-}
-- |
-- Decoder of the @TIMESTAMPTZ@ values.
--
-- /NOTICE/
--
-- Postgres does not store the timezone information of @TIMESTAMPTZ@.
-- Instead it stores a UTC value and performs silent conversions
-- to the currently set timezone, when dealt with in the text format.
-- However this library bypasses the silent conversions
-- and communicates with Postgres using the UTC values directly.
{-# INLINEABLE timestamptz #-}
timestamptz :: Value B.UTCTime
timestamptz = Value (Value.decoder (Prelude.bool A.timestamptz_float A.timestamptz_int))
{-|
Decoder of the @TIME@ values.
-}
{-# INLINABLE time #-}
-- |
-- Decoder of the @TIME@ values.
{-# INLINEABLE time #-}
time :: Value B.TimeOfDay
time = Value (Value.decoder (Prelude.bool A.time_float A.time_int))
{-|
Decoder of the @TIMETZ@ values.
Unlike in case of @TIMESTAMPTZ@,
Postgres does store the timezone information for @TIMETZ@.
However the Haskell's \"time\" library does not contain any composite type,
that fits the task, so we use a pair of 'TimeOfDay' and 'TimeZone'
to represent a value on the Haskell's side.
-}
{-# INLINABLE timetz #-}
-- |
-- Decoder of the @TIMETZ@ values.
--
-- Unlike in case of @TIMESTAMPTZ@,
-- Postgres does store the timezone information for @TIMETZ@.
-- However the Haskell's \"time\" library does not contain any composite type,
-- that fits the task, so we use a pair of 'TimeOfDay' and 'TimeZone'
-- to represent a value on the Haskell's side.
{-# INLINEABLE timetz #-}
timetz :: Value (B.TimeOfDay, B.TimeZone)
timetz = Value (Value.decoder (Prelude.bool A.timetz_float A.timetz_int))
{-|
Decoder of the @INTERVAL@ values.
-}
{-# INLINABLE interval #-}
-- |
-- Decoder of the @INTERVAL@ values.
{-# INLINEABLE interval #-}
interval :: Value B.DiffTime
interval = Value (Value.decoder (Prelude.bool A.interval_float A.interval_int))
{-|
Decoder of the @UUID@ values.
-}
{-# INLINABLE uuid #-}
-- |
-- Decoder of the @UUID@ values.
{-# INLINEABLE uuid #-}
uuid :: Value B.UUID
uuid = Value (Value.decoder (const A.uuid))
{-|
Decoder of the @INET@ values.
-}
{-# INLINABLE inet #-}
-- |
-- Decoder of the @INET@ values.
{-# INLINEABLE inet #-}
inet :: Value (B.NetAddr B.IP)
inet = Value (Value.decoder (const A.inet))
{-|
Decoder of the @JSON@ values into a JSON AST.
-}
{-# INLINABLE json #-}
-- |
-- Decoder of the @JSON@ values into a JSON AST.
{-# INLINEABLE json #-}
json :: Value B.Value
json = Value (Value.decoder (const A.json_ast))
{-|
Decoder of the @JSON@ values into a raw JSON 'ByteString'.
-}
{-# INLINABLE jsonBytes #-}
-- |
-- Decoder of the @JSON@ values into a raw JSON 'ByteString'.
{-# INLINEABLE jsonBytes #-}
jsonBytes :: (ByteString -> Either Text a) -> Value a
jsonBytes fn = Value (Value.decoder (const (A.json_bytes fn)))
{-|
Decoder of the @JSONB@ values into a JSON AST.
-}
{-# INLINABLE jsonb #-}
-- |
-- Decoder of the @JSONB@ values into a JSON AST.
{-# INLINEABLE jsonb #-}
jsonb :: Value B.Value
jsonb = Value (Value.decoder (const A.jsonb_ast))
{-|
Decoder of the @JSONB@ values into a raw JSON 'ByteString'.
-}
{-# INLINABLE jsonbBytes #-}
-- |
-- Decoder of the @JSONB@ values into a raw JSON 'ByteString'.
{-# INLINEABLE jsonbBytes #-}
jsonbBytes :: (ByteString -> Either Text a) -> Value a
jsonbBytes fn = Value (Value.decoder (const (A.jsonb_bytes fn)))
{-|
Lift a custom value decoder function to a 'Value' decoder.
-}
{-# INLINABLE custom #-}
-- |
-- Lift a custom value decoder function to a 'Value' decoder.
{-# INLINEABLE custom #-}
custom :: (Bool -> ByteString -> Either Text a) -> Value a
custom fn = Value (Value.decoderFn fn)
{-|
Refine a value decoder, lifting the possible error to the session level.
-}
{-# INLINABLE refine #-}
-- |
-- Refine a value decoder, lifting the possible error to the session level.
{-# INLINEABLE refine #-}
refine :: (a -> Either Text b) -> Value a -> Value b
refine fn (Value v) = Value (Value.Value (\b -> A.refine fn (Value.run v b)))
{-|
A generic decoder of @HSTORE@ values.
Here's how you can use it to construct a specific value:
@
x :: Value [(Text, Maybe Text)]
x = hstore 'replicateM'
@
-}
{-# INLINABLE hstore #-}
-- |
-- A generic decoder of @HSTORE@ values.
--
-- Here's how you can use it to construct a specific value:
--
-- @
-- x :: Value [(Text, Maybe Text)]
-- x = hstore 'replicateM'
-- @
{-# INLINEABLE hstore #-}
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)))
{-|
Given a partial mapping from text to value,
produces a decoder of that value.
-}
-- |
-- Given a partial mapping from text to value,
-- produces a decoder of that value.
enum :: (Text -> Maybe a) -> Value a
enum mapping = Value (Value.decoder (const (A.enum mapping)))
{-|
Lift an 'Array' decoder to a 'Value' decoder.
-}
{-# INLINABLE array #-}
-- |
-- Lift an 'Array' decoder to a 'Value' decoder.
{-# INLINEABLE array #-}
array :: Array a -> Value a
array (Array imp) = Value (Value.decoder (Array.run imp))
{-|
Lift a value decoder of element into a unidimensional array decoder producing a list.
This function is merely a shortcut to the following expression:
@
('array' . 'dimension' Control.Monad.'replicateM' . 'element')
@
Please notice that in case of multidimensional arrays nesting 'listArray' decoder
won't work. You have to explicitly construct the array decoder using 'array'.
-}
-- |
-- Lift a value decoder of element into a unidimensional array decoder producing a list.
--
-- This function is merely a shortcut to the following expression:
--
-- @
-- ('array' . 'dimension' Control.Monad.'replicateM' . 'element')
-- @
--
-- Please notice that in case of multidimensional arrays nesting 'listArray' decoder
-- won't work. You have to explicitly construct the array decoder using 'array'.
{-# INLINE listArray #-}
listArray :: NullableOrNot Value element -> Value [element]
listArray = array . dimension replicateM . element
{-|
Lift a value decoder of element into a unidimensional array decoder producing a generic vector.
This function is merely a shortcut to the following expression:
@
('array' . 'dimension' Data.Vector.Generic.'GenericVector.replicateM' . 'element')
@
Please notice that in case of multidimensional arrays nesting 'vectorArray' decoder
won't work. You have to explicitly construct the array decoder using 'array'.
-}
-- |
-- Lift a value decoder of element into a unidimensional array decoder producing a generic vector.
--
-- This function is merely a shortcut to the following expression:
--
-- @
-- ('array' . 'dimension' Data.Vector.Generic.'GenericVector.replicateM' . 'element')
-- @
--
-- 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 = array . dimension GenericVector.replicateM . element
{-|
Lift a 'Composite' decoder to a 'Value' decoder.
-}
{-# INLINABLE composite #-}
-- |
-- Lift a 'Composite' decoder to a 'Value' decoder.
{-# INLINEABLE composite #-}
composite :: Composite a -> Value a
composite (Composite imp) = Value (Value.decoder (Composite.run imp))
-- * Array decoders
-------------------------
{-|
A generic array decoder.
Here's how you can use it to produce a specific array value decoder:
@
x :: 'Value' [[Text]]
x = 'array' ('dimension' 'replicateM' ('dimension' 'replicateM' ('element' ('nonNullable' 'text'))))
@
-}
-- |
-- A generic array decoder.
--
-- Here's how you can use it to produce a specific array value decoder:
--
-- @
-- x :: 'Value' [[Text]]
-- x = 'array' ('dimension' 'replicateM' ('dimension' 'replicateM' ('element' ('nonNullable' 'text'))))
-- @
newtype Array a = Array (Array.Array a)
deriving (Functor)
{-|
A function for parsing a dimension of an array.
Provides support for multi-dimensional arrays.
Accepts:
* An implementation of the @replicateM@ function
(@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@),
which determines the output value.
* A decoder of its components, which can be either another 'dimension' or 'element'.
-}
{-# INLINABLE dimension #-}
-- |
-- A function for parsing a dimension of an array.
-- Provides support for multi-dimensional arrays.
--
-- Accepts:
--
-- * An implementation of the @replicateM@ function
-- (@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@),
-- which determines the output value.
--
-- * 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 replicateM (Array imp) = Array (Array.dimension replicateM imp)
{-|
Lift a 'Value' decoder into an 'Array' decoder for parsing of leaf values.
-}
{-# INLINABLE element #-}
-- |
-- Lift a 'Value' decoder into an 'Array' decoder for parsing of leaf values.
{-# INLINEABLE element #-}
element :: NullableOrNot Value a -> Array a
element = \ case
element = \case
NonNullable (Value imp) -> Array (Array.nonNullValue (Value.run imp))
Nullable (Value imp) -> Array (Array.value (Value.run imp))
-- * Composite decoders
-------------------------
{-|
Composable decoder of composite values (rows, records).
-}
-- |
-- Composable decoder of composite values (rows, records).
newtype Composite a = Composite (Composite.Composite a)
deriving (Functor, Applicative, Monad, MonadFail)
{-|
Lift a 'Value' decoder into a 'Composite' decoder for parsing of component values.
-}
-- |
-- Lift a 'Value' decoder into a 'Composite' decoder for parsing of component values.
field :: NullableOrNot Value a -> Composite a
field = \ case
field = \case
NonNullable (Value imp) -> Composite (Composite.nonNullValue (Value.run imp))
Nullable (Value imp) -> Composite (Composite.value (Value.run imp))

6
library/Hasql/Private/Decoders/Array.hs
View File

@ -3,9 +3,8 @@ module Hasql.Private.Decoders.Array where
import Hasql.Private.Prelude
import qualified PostgreSQL.Binary.Decoding as A
newtype Array a =
Array (ReaderT Bool A.Array a)
newtype Array a
= Array (ReaderT Bool A.Array a)
deriving (Functor)
{-# INLINE run #-}
@ -27,4 +26,3 @@ value decoder' =
nonNullValue :: (Bool -> A.Value a) -> Array a
nonNullValue decoder' =
Array $ ReaderT $ A.valueArray . decoder'

6
library/Hasql/Private/Decoders/Composite.hs
View File

@ -3,9 +3,8 @@ module Hasql.Private.Decoders.Composite where
import Hasql.Private.Prelude
import qualified PostgreSQL.Binary.Decoding as A
newtype Composite a =
Composite (ReaderT Bool A.Composite a)
newtype Composite a
= Composite (ReaderT Bool A.Composite a)
deriving (Functor, Applicative, Monad, MonadFail)
{-# INLINE run #-}
@ -22,4 +21,3 @@ value decoder' =
nonNullValue :: (Bool -> A.Value a) -> Composite a
nonNullValue decoder' =
Composite $ ReaderT $ A.valueComposite . decoder'

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

@ -1,18 +1,17 @@
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
import qualified Data.ByteString as ByteString
import qualified Hasql.Private.Prelude as Prelude
import qualified Data.Vector as Vector
import qualified Data.Vector.Mutable as MutableVector
import qualified Database.PostgreSQL.LibPQ as LibPQ
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
newtype Result a =
Result (ReaderT (Bool, LibPQ.Result) (ExceptT ResultError IO) a)
newtype Result a
= Result (ReaderT (Bool, LibPQ.Result) (ExceptT ResultError IO) a)
deriving (Functor, Applicative, Monad)
{-# INLINE run #-}
@ -35,8 +34,10 @@ rowsAffected =
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,36 +50,37 @@ rowsAffected =
else Right bytes
decimal bytes =
mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m)) $
Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes
Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes
{-# INLINE checkExecStatus #-}
checkExecStatus :: (LibPQ.ExecStatus -> Bool) -> Result ()
checkExecStatus predicate =
{-# SCC "checkExecStatus" #-}
{-# SCC "checkExecStatus" #-}
do
status <- Result $ ReaderT $ \(_, result) -> lift $ LibPQ.resultStatus result
unless (predicate status) $ do
case status of
LibPQ.BadResponse -> serverError
LibPQ.BadResponse -> serverError
LibPQ.NonfatalError -> serverError
LibPQ.FatalError -> serverError
LibPQ.FatalError -> serverError
_ -> Result $ lift $ ExceptT $ pure $ Left $ UnexpectedResult $ "Unexpected result status: " <> (fromString $ show status)
{-# INLINE serverError #-}
serverError :: Result ()
serverError =
Result $ ReaderT $ \(_, result) -> ExceptT $ do
code <-
fmap fold $
LibPQ.resultErrorField result LibPQ.DiagSqlstate
message <-
fmap fold $
LibPQ.resultErrorField result LibPQ.DiagMessagePrimary
detail <-
LibPQ.resultErrorField result LibPQ.DiagMessageDetail
hint <-
LibPQ.resultErrorField result LibPQ.DiagMessageHint
pure $ Left $ ServerError code message detail hint
Result $
ReaderT $ \(_, result) -> ExceptT $ do
code <-
fmap fold $
LibPQ.resultErrorField result LibPQ.DiagSqlstate
message <-
fmap fold $
LibPQ.resultErrorField result LibPQ.DiagMessagePrimary
detail <-
LibPQ.resultErrorField result LibPQ.DiagMessageDetail
hint <-
LibPQ.resultErrorField result LibPQ.DiagMessageHint
pure $ Left $ ServerError code message detail hint
{-# INLINE maybe #-}
maybe :: Row.Row a -> Result (Maybe a)
@ -87,15 +89,16 @@ maybe rowDec =
checkExecStatus $ \case
LibPQ.TuplesOk -> True
_ -> False
Result $ ReaderT $ \(integerDatetimes, result) -> ExceptT $ do
maxRows <- LibPQ.ntuples result
case maxRows of
0 -> return (Right Nothing)
1 -> do
maxCols <- LibPQ.nfields result
let fromRowError (col, err) = RowError 0 col err
fmap (fmap Just . mapLeft fromRowError) $ Row.run rowDec (result, 0, maxCols, integerDatetimes)
_ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))
Result $
ReaderT $ \(integerDatetimes, result) -> ExceptT $ do
maxRows <- LibPQ.ntuples result
case maxRows of
0 -> return (Right Nothing)
1 -> do
maxCols <- LibPQ.nfields result
let fromRowError (col, err) = RowError 0 col err
fmap (fmap Just . mapLeft fromRowError) $ Row.run rowDec (result, 0, maxCols, integerDatetimes)
_ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))
where
rowToInt (LibPQ.Row n) =
fromIntegral n
@ -109,14 +112,15 @@ single rowDec =
checkExecStatus $ \case
LibPQ.TuplesOk -> True
_ -> False
Result $ ReaderT $ \(integerDatetimes, result) -> ExceptT $ do
maxRows <- LibPQ.ntuples result
case maxRows of
1 -> do
maxCols <- LibPQ.nfields result
let fromRowError (col, err) = RowError 0 col err
fmap (mapLeft fromRowError) $ Row.run rowDec (result, 0, maxCols, integerDatetimes)
_ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))
Result $
ReaderT $ \(integerDatetimes, result) -> ExceptT $ do
maxRows <- LibPQ.ntuples result
case maxRows of
1 -> do
maxCols <- LibPQ.nfields result
let fromRowError (col, err) = RowError 0 col err
fmap (mapLeft fromRowError) $ Row.run rowDec (result, 0, maxCols, integerDatetimes)
_ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))
where
rowToInt (LibPQ.Row n) =
fromIntegral n
@ -130,19 +134,20 @@ vector rowDec =
checkExecStatus $ \case
LibPQ.TuplesOk -> True
_ -> False
Result $ ReaderT $ \(integerDatetimes, result) -> ExceptT $ do
maxRows <- LibPQ.ntuples result
maxCols <- LibPQ.nfields result
mvector <- MutableVector.unsafeNew (rowToInt maxRows)
failureRef <- newIORef Nothing
forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do
rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes)
case rowResult of
Left !(!colIndex,!x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x))
Right !x -> MutableVector.unsafeWrite mvector rowIndex x
readIORef failureRef >>= \case
Nothing -> Right <$> Vector.unsafeFreeze mvector
Just x -> pure (Left x)
Result $
ReaderT $ \(integerDatetimes, result) -> ExceptT $ do
maxRows <- LibPQ.ntuples result
maxCols <- LibPQ.nfields result
mvector <- MutableVector.unsafeNew (rowToInt maxRows)
failureRef <- newIORef Nothing
forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do
rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes)
case rowResult of
Left !(!colIndex, !x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x))
Right !x -> MutableVector.unsafeWrite mvector rowIndex x
readIORef failureRef >>= \case
Nothing -> Right <$> Vector.unsafeFreeze mvector
Just x -> pure (Left x)
where
rowToInt (LibPQ.Row n) =
fromIntegral n
@ -152,24 +157,28 @@ vector rowDec =
{-# INLINE foldl #-}
foldl :: (a -> b -> a) -> a -> Row.Row b -> Result a
foldl step init rowDec =
{-# SCC "foldl" #-}
{-# SCC "foldl" #-}
do
checkExecStatus $ \case
LibPQ.TuplesOk -> True
_ -> False
Result $ ReaderT $ \(integerDatetimes, result) -> ExceptT $ {-# SCC "traversal" #-} do
maxRows <- LibPQ.ntuples result
maxCols <- LibPQ.nfields result
accRef <- newIORef init
failureRef <- newIORef Nothing
forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do
rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes)
case rowResult of
Left !(!colIndex,!x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x))
Right !x -> modifyIORef' accRef (\acc -> step acc x)
readIORef failureRef >>= \case
Nothing -> Right <$> readIORef accRef
Just x -> pure (Left x)
Result $
ReaderT $ \(integerDatetimes, result) ->
ExceptT $
{-# SCC "traversal" #-}
do
maxRows <- LibPQ.ntuples result
maxCols <- LibPQ.nfields result
accRef <- newIORef init
failureRef <- newIORef Nothing
forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do
rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes)
case rowResult of
Left !(!colIndex, !x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x))
Right !x -> modifyIORef' accRef (\acc -> step acc x)
readIORef failureRef >>= \case
Nothing -> Right <$> readIORef accRef
Just x -> pure (Left x)
where
rowToInt (LibPQ.Row n) =
fromIntegral n
@ -179,24 +188,25 @@ foldl step init rowDec =
{-# INLINE foldr #-}
foldr :: (b -> a -> a) -> a -> Row.Row b -> Result a
foldr step init rowDec =
{-# SCC "foldr" #-}
{-# SCC "foldr" #-}
do
checkExecStatus $ \case
LibPQ.TuplesOk -> True
_ -> False
Result $ ReaderT $ \(integerDatetimes, result) -> ExceptT $ do
maxRows <- LibPQ.ntuples result
maxCols <- LibPQ.nfields result
accRef <- newIORef init
failureRef <- newIORef Nothing
forMToZero_ (rowToInt maxRows) $ \rowIndex -> do
rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes)
case rowResult of
Left !(!colIndex,!x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x))
Right !x -> modifyIORef accRef (\acc -> step x acc)
readIORef failureRef >>= \case
Nothing -> Right <$> readIORef accRef
Just x -> pure (Left x)
Result $
ReaderT $ \(integerDatetimes, result) -> ExceptT $ do
maxRows <- LibPQ.ntuples result
maxCols <- LibPQ.nfields result
accRef <- newIORef init
failureRef <- newIORef Nothing
forMToZero_ (rowToInt maxRows) $ \rowIndex -> do
rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes)
case rowResult of
Left !(!colIndex, !x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x))
Right !x -> modifyIORef accRef (\acc -> step x acc)
readIORef failureRef >>= \case
Nothing -> Right <$> readIORef accRef
Just x -> pure (Left x)
where
rowToInt (LibPQ.Row n) =
fromIntegral n

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

@ -1,29 +1,26 @@
-- |
-- 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.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
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
newtype Results a =
Results (ReaderT (Bool, LibPQ.Connection) (ExceptT CommandError IO) a)
newtype Results a
= Results (ReaderT (Bool, LibPQ.Connection) (ExceptT CommandError IO) a)
deriving (Functor, Applicative, Monad)
{-# INLINE run #-}
run :: Results a -> (Bool, LibPQ.Connection) -> IO (Either CommandError a)
run (Results stack) env =
@ -32,32 +29,36 @@ run (Results stack) env =
{-# 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
resultMaybe <- LibPQ.getResult connection
case resultMaybe of
Just result ->
mapLeft ResultError <$> Result.run resultDec (integerDatetimes, result)
Nothing ->
fmap (Left . ClientError) (LibPQ.errorMessage connection)
Results $
ReaderT $ \(integerDatetimes, connection) -> ExceptT $ do
resultMaybe <- LibPQ.getResult connection
case resultMaybe of
Just result ->
mapLeft ResultError <$> Result.run resultDec (integerDatetimes, result)
Nothing ->
fmap (Left . ClientError) (LibPQ.errorMessage connection)
-- |
-- Fetch a single result.
{-# INLINE getResult #-}
getResult :: Results LibPQ.Result
getResult =
Results $ ReaderT $ \(_, connection) -> ExceptT $ do
resultMaybe <- LibPQ.getResult connection
case resultMaybe of
Just result -> pure (Right result)
Nothing -> fmap (Left . ClientError) (LibPQ.errorMessage connection)
Results $
ReaderT $ \(_, connection) -> ExceptT $ do
resultMaybe <- LibPQ.getResult connection
case resultMaybe of
Just result -> pure (Right result)
Nothing -> fmap (Left . ClientError) (LibPQ.errorMessage connection)
-- |
-- Fetch a single result.
@ -69,7 +70,7 @@ getResultMaybe =
{-# INLINE dropRemainders #-}
dropRemainders :: Results ()
dropRemainders =
{-# SCC "dropRemainders" #-}
{-# SCC "dropRemainders" #-}
Results $ ReaderT $ \(integerDatetimes, connection) -> loop integerDatetimes connection
where
loop integerDatetimes connection =
@ -84,6 +85,7 @@ dropRemainders =
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
resultEither <- run results env
return $ resultEither >>= mapLeft (ResultError . UnexpectedResult) . refiner
refine refiner results = Results $
ReaderT $ \env -> ExceptT $ do
resultEither <- run results env
return $ resultEither >>= mapLeft (ResultError . UnexpectedResult) . refiner

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

@ -1,24 +1,23 @@
module Hasql.Private.Decoders.Row where
import Hasql.Private.Prelude hiding (error)
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
import Hasql.Private.Errors
import Hasql.Private.Prelude hiding (error)
import qualified PostgreSQL.Binary.Decoding as A
newtype Row a =
Row (ReaderT Env (ExceptT RowError IO) a)
newtype Row a
= Row (ReaderT Env (ExceptT RowError IO) a)
deriving (Functor, Applicative, Monad)
instance MonadFail Row where
fail = error . ValueError . fromString
data Env =
Env !LibPQ.Result !LibPQ.Row !LibPQ.Column !Bool !(IORef LibPQ.Column)
data Env
= Env !LibPQ.Result !LibPQ.Row !LibPQ.Column !Bool !(IORef LibPQ.Column)
-- * Functions
-------------------------
{-# INLINE run #-}
@ -44,20 +43,22 @@ error x =
value :: Value.Value a -> Row (Maybe a)
value valueDec =
{-# SCC "value" #-}
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
Nothing ->
Right Nothing
Just value ->
fmap Just $ mapLeft ValueError $
{-# SCC "decode" #-} A.valueParser (Value.run valueDec integerDatetimes) value
else pure (Left EndOfInput)
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
Nothing ->
Right Nothing
Just value ->
fmap Just $
mapLeft ValueError $
{-# SCC "decode" #-} A.valueParser (Value.run valueDec integerDatetimes) value
else pure (Left EndOfInput)
-- |
-- Next value, decoded using the provided value decoder.

7
library/Hasql/Private/Decoders/Value.hs
View File

@ -3,9 +3,8 @@ module Hasql.Private.Decoders.Value where
import Hasql.Private.Prelude
import qualified PostgreSQL.Binary.Decoding as A
newtype Value a =
Value (Bool -> A.Value a)
newtype Value a
= Value (Bool -> A.Value a)
deriving (Functor)
{-# INLINE run #-}
@ -16,7 +15,7 @@ run (Value imp) integerDatetimes =
{-# INLINE decoder #-}
decoder :: (Bool -> A.Value a) -> Value a
decoder =
{-# SCC "decoder" #-}
{-# SCC "decoder" #-}
Value
{-# INLINE decoderFn #-}

444
library/Hasql/Private/Encoders.hs
View File

@ -1,371 +1,333 @@
{-|
A DSL for declaration of query parameter encoders.
-}
module Hasql.Private.Encoders
where
-- |
-- A DSL for declaration of query parameter encoders.
module Hasql.Private.Encoders 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.Array as Array
import qualified Hasql.Private.Encoders.Params as Params
import qualified Hasql.Private.Encoders.Value as Value
import qualified Hasql.Private.Encoders.Array as Array
import qualified Hasql.Private.PTI as PTI
import Hasql.Private.Prelude hiding (bool)
import qualified Hasql.Private.Prelude as Prelude
import qualified PostgreSQL.Binary.Data as B
import qualified PostgreSQL.Binary.Encoding as A
import qualified Text.Builder as C
-- * Parameters Product Encoder
-------------------------
{-|
Encoder of some representation of a parameters product.
Has instances of 'Contravariant', 'Divisible' and 'Monoid',
which you can use to compose multiple parameters together.
E.g.,
@
someParamsEncoder :: 'Params' (Int64, Maybe Text)
someParamsEncoder =
('fst' '>$<' 'param' ('nonNullable' 'int8')) '<>'
('snd' '>$<' 'param' ('nullable' 'text'))
@
As a general solution for tuples of any arity, instead of 'fst' and 'snd',
consider the functions of the @contrazip@ family
from the \"contravariant-extras\" package.
E.g., here's how you can achieve the same as the above:
@
someParamsEncoder :: 'Params' (Int64, Maybe Text)
someParamsEncoder =
'contrazip2' ('param' ('nonNullable' 'int8')) ('param' ('nullable' 'text'))
@
Here's how you can implement encoders for custom composite types:
@
data Person = Person { name :: Text, gender :: Gender, age :: Int }
data Gender = Male | Female
personParams :: 'Params' Person
personParams =
(name '>$<' 'param' ('nonNullable' 'text')) '<>'
(gender '>$<' 'param' ('nonNullable' genderValue)) '<>'
('fromIntegral' . age '>$<' 'param' ('nonNullable' 'int8'))
genderValue :: 'Value' Gender
genderValue = 'enum' genderText 'text' where
genderText gender = case gender of
Male -> "male"
Female -> "female"
@
-}
-- |
-- Encoder of some representation of a parameters product.
--
-- Has instances of 'Contravariant', 'Divisible' and 'Monoid',
-- which you can use to compose multiple parameters together.
-- E.g.,
--
-- @
-- someParamsEncoder :: 'Params' (Int64, Maybe Text)
-- someParamsEncoder =
-- ('fst' '>$<' 'param' ('nonNullable' 'int8')) '<>'
-- ('snd' '>$<' 'param' ('nullable' 'text'))
-- @
--
-- As a general solution for tuples of any arity, instead of 'fst' and 'snd',
-- consider the functions of the @contrazip@ family
-- from the \"contravariant-extras\" package.
-- E.g., here's how you can achieve the same as the above:
--
-- @
-- someParamsEncoder :: 'Params' (Int64, Maybe Text)
-- someParamsEncoder =
-- 'contrazip2' ('param' ('nonNullable' 'int8')) ('param' ('nullable' 'text'))
-- @
--
-- Here's how you can implement encoders for custom composite types:
--
-- @
-- data Person = Person { name :: Text, gender :: Gender, age :: Int }
--
-- data Gender = Male | Female
--
-- personParams :: 'Params' Person
-- personParams =
-- (name '>$<' 'param' ('nonNullable' 'text')) '<>'
-- (gender '>$<' 'param' ('nonNullable' genderValue)) '<>'
-- ('fromIntegral' . age '>$<' 'param' ('nonNullable' 'int8'))
--
-- genderValue :: 'Value' Gender
-- genderValue = 'enum' genderText 'text' where
-- genderText gender = case gender of
-- Male -> "male"
-- Female -> "female"
-- @
newtype Params a = Params (Params.Params a)
deriving (Contravariant, Divisible, Decidable, Monoid, Semigroup)
{-|
No parameters. Same as `mempty` and `conquered`.
-}
-- |
-- No parameters. Same as `mempty` and `conquered`.
noParams :: Params ()
noParams = mempty
{-|
Lift a single parameter encoder, with its nullability specified,
associating it with a single placeholder.
-}
-- |
-- Lift a single parameter encoder, with its nullability specified,
-- associating it with a single placeholder.
param :: NullableOrNot Value a -> Params a
param = \ case
param = \case
NonNullable (Value valueEnc) -> Params (Params.value valueEnc)
Nullable (Value valueEnc) -> Params (Params.nullableValue valueEnc)
-- * Nullability
-------------------------
{-|
Extensional specification of nullability over a generic encoder.
-}
-- |
-- Extensional specification of nullability over a generic encoder.
data NullableOrNot encoder a where
NonNullable :: encoder a -> NullableOrNot encoder a
Nullable :: encoder a -> NullableOrNot encoder (Maybe a)
{-|
Specify that an encoder produces a non-nullable value.
-}
-- |
-- Specify that an encoder produces a non-nullable value.
nonNullable :: encoder a -> NullableOrNot encoder a
nonNullable = NonNullable
{-|
Specify that an encoder produces a nullable value.
-}
-- |
-- Specify that an encoder produces a nullable value.
nullable :: encoder a -> NullableOrNot encoder (Maybe a)
nullable = Nullable
-- * Value
-------------------------
{-|
Value encoder.
-}
-- |
-- Value encoder.
newtype Value a = Value (Value.Value a)
deriving (Contravariant)
{-|
Encoder of @BOOL@ values.
-}
{-# INLINABLE bool #-}
-- |
-- Encoder of @BOOL@ values.
{-# INLINEABLE bool #-}
bool :: Value Bool
bool = Value (Value.unsafePTIWithShow PTI.bool (const A.bool))
{-|
Encoder of @INT2@ values.
-}
{-# INLINABLE int2 #-}
-- |
-- Encoder of @INT2@ values.
{-# INLINEABLE int2 #-}
int2 :: Value Int16
int2 = Value (Value.unsafePTIWithShow PTI.int2 (const A.int2_int16))
{-|
Encoder of @INT4@ values.
-}
{-# INLINABLE int4 #-}
-- |
-- Encoder of @INT4@ values.
{-# INLINEABLE int4 #-}
int4 :: Value Int32
int4 = Value (Value.unsafePTIWithShow PTI.int4 (const A.int4_int32))
{-|
Encoder of @INT8@ values.
-}
{-# INLINABLE int8 #-}
-- |
-- Encoder of @INT8@ values.
{-# INLINEABLE int8 #-}
int8 :: Value Int64
int8 = Value (Value.unsafePTIWithShow PTI.int8 (const A.int8_int64))
{-|
Encoder of @FLOAT4@ values.
-}
{-# INLINABLE float4 #-}
-- |
-- Encoder of @FLOAT4@ values.
{-# INLINEABLE float4 #-}
float4 :: Value Float
float4 = Value (Value.unsafePTIWithShow PTI.float4 (const A.float4))
{-|
Encoder of @FLOAT8@ values.
-}
{-# INLINABLE float8 #-}
-- |
-- Encoder of @FLOAT8@ values.
{-# INLINEABLE float8 #-}
float8 :: Value Double
float8 = Value (Value.unsafePTIWithShow PTI.float8 (const A.float8))
{-|
Encoder of @NUMERIC@ values.
-}
{-# INLINABLE numeric #-}
-- |
-- Encoder of @NUMERIC@ values.
{-# INLINEABLE numeric #-}
numeric :: Value B.Scientific
numeric = Value (Value.unsafePTIWithShow PTI.numeric (const A.numeric))
{-|
Encoder of @CHAR@ values.
Note that it supports Unicode values and
identifies itself under the @TEXT@ OID because of that.
-}
{-# INLINABLE char #-}
-- |
-- Encoder of @CHAR@ values.
--
-- Note that it supports Unicode values and
-- identifies itself under the @TEXT@ OID because of that.
{-# INLINEABLE char #-}
char :: Value Char
char = Value (Value.unsafePTIWithShow PTI.text (const A.char_utf8))
{-|
Encoder of @TEXT@ values.
-}
{-# INLINABLE text #-}
-- |
-- Encoder of @TEXT@ values.
{-# INLINEABLE text #-}
text :: Value Text
text = Value (Value.unsafePTIWithShow PTI.text (const A.text_strict))
{-|
Encoder of @BYTEA@ values.
-}
{-# INLINABLE bytea #-}
-- |
-- Encoder of @BYTEA@ values.
{-# INLINEABLE bytea #-}
bytea :: Value ByteString
bytea = Value (Value.unsafePTIWithShow PTI.bytea (const A.bytea_strict))
{-|
Encoder of @DATE@ values.
-}
{-# INLINABLE date #-}
-- |
-- Encoder of @DATE@ values.
{-# INLINEABLE date #-}
date :: Value B.Day
date = Value (Value.unsafePTIWithShow PTI.date (const A.date))
{-|
Encoder of @TIMESTAMP@ values.
-}
{-# INLINABLE timestamp #-}
-- |
-- Encoder of @TIMESTAMP@ values.
{-# INLINEABLE timestamp #-}
timestamp :: Value B.LocalTime
timestamp = Value (Value.unsafePTIWithShow PTI.timestamp (Prelude.bool A.timestamp_float A.timestamp_int))
{-|
Encoder of @TIMESTAMPTZ@ values.
-}
{-# INLINABLE timestamptz #-}
-- |
-- Encoder of @TIMESTAMPTZ@ values.
{-# INLINEABLE timestamptz #-}
timestamptz :: Value B.UTCTime
timestamptz = Value (Value.unsafePTIWithShow PTI.timestamptz (Prelude.bool A.timestamptz_float A.timestamptz_int))
{-|
Encoder of @TIME@ values.
-}
{-# INLINABLE time #-}
-- |
-- Encoder of @TIME@ values.
{-# INLINEABLE time #-}
time :: Value B.TimeOfDay
time = Value (Value.unsafePTIWithShow PTI.time (Prelude.bool A.time_float A.time_int))
{-|
Encoder of @TIMETZ@ values.
-}
{-# INLINABLE timetz #-}
-- |
-- Encoder of @TIMETZ@ values.
{-# INLINEABLE timetz #-}
timetz :: Value (B.TimeOfDay, B.TimeZone)
timetz = Value (Value.unsafePTIWithShow PTI.timetz (Prelude.bool A.timetz_float A.timetz_int))
{-|
Encoder of @INTERVAL@ values.
-}
{-# INLINABLE interval #-}
-- |
-- Encoder of @INTERVAL@ values.
{-# INLINEABLE interval #-}
interval :: Value B.DiffTime
interval = Value (Value.unsafePTIWithShow PTI.interval (Prelude.bool A.interval_float A.interval_int))
{-|
Encoder of @UUID@ values.
-}
{-# INLINABLE uuid #-}
-- |
-- Encoder of @UUID@ values.
{-# INLINEABLE uuid #-}
uuid :: Value B.UUID
uuid = Value (Value.unsafePTIWithShow PTI.uuid (const A.uuid))
{-|
Encoder of @INET@ values.
-}
{-# INLINABLE inet #-}
-- |
-- Encoder of @INET@ values.
{-# INLINEABLE inet #-}
inet :: Value (B.NetAddr B.IP)
inet = Value (Value.unsafePTIWithShow PTI.inet (const A.inet))
{-|
Encoder of @JSON@ values from JSON AST.
-}
{-# INLINABLE json #-}
-- |
-- Encoder of @JSON@ values from JSON AST.
{-# INLINEABLE json #-}
json :: Value B.Value
json = Value (Value.unsafePTIWithShow PTI.json (const A.json_ast))
{-|
Encoder of @JSON@ values from raw JSON.
-}
{-# INLINABLE jsonBytes #-}
-- |
-- Encoder of @JSON@ values from raw JSON.
{-# INLINEABLE jsonBytes #-}
jsonBytes :: Value ByteString
jsonBytes = Value (Value.unsafePTIWithShow PTI.json (const A.json_bytes))
{-|
Encoder of @JSONB@ values from JSON AST.
-}
{-# INLINABLE jsonb #-}
-- |
-- Encoder of @JSONB@ values from JSON AST.
{-# INLINEABLE jsonb #-}
jsonb :: Value B.Value
jsonb = Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_ast))
{-|
Encoder of @JSONB@ values from raw JSON.
-}
{-# INLINABLE jsonbBytes #-}
-- |
-- Encoder of @JSONB@ values from raw JSON.
{-# INLINEABLE jsonbBytes #-}
jsonbBytes :: Value ByteString
jsonbBytes = Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_bytes))
{-|
Given a function,
which maps a value into a textual enum label used on the DB side,
produces an encoder of that value.
-}
{-# INLINABLE enum #-}
-- |
-- Given a function,
-- which maps a value into a textual enum label used on the DB side,
-- produces an encoder of that value.
{-# INLINEABLE enum #-}
enum :: (a -> Text) -> Value a
enum mapping = Value (Value.unsafePTI PTI.text (const (A.text_strict . mapping)) (C.text . mapping))
{-|
Identifies the value with the PostgreSQL's \"unknown\" type,
thus leaving it up to Postgres to infer the actual type of the value.
The value transimitted is any value encoded in the Postgres' Text data format.
For reference, see the
<https://www.postgresql.org/docs/10/static/protocol-overview.html#protocol-format-codes Formats and Format Codes>
section of the Postgres' documentation.
-}
{-# INLINABLE unknown #-}
-- |
-- Identifies the value with the PostgreSQL's \"unknown\" type,
-- thus leaving it up to Postgres to infer the actual type of the value.
--
-- The value transimitted is any value encoded in the Postgres' Text data format.
-- For reference, see the
-- <https://www.postgresql.org/docs/10/static/protocol-overview.html#protocol-format-codes Formats and Format Codes>
-- section of the Postgres' documentation.
{-# INLINEABLE unknown #-}
unknown :: Value ByteString
unknown = Value (Value.unsafePTIWithShow PTI.unknown (const A.bytea_strict))
{-|
Lift an array encoder into a parameter encoder.
-}
-- |
-- Lift an array encoder into a parameter encoder.
array :: Array a -> Value a
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)
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)
{-|
Lift a value encoder of element into a unidimensional array encoder of a foldable value.
This function is merely a shortcut to the following expression:
@
('array' . 'dimension' 'foldl'' . 'element')
@
You can use it like this:
@
vectorOfInts :: Value (Vector Int64)
vectorOfInts = 'foldableArray' ('nonNullable' 'int8')
@
Please notice that in case of multidimensional arrays nesting 'foldableArray' encoder
won't work. You have to explicitly construct the array encoder using 'array'.
-}
-- |
-- Lift a value encoder of element into a unidimensional array encoder of a foldable value.
--
-- This function is merely a shortcut to the following expression:
--
-- @
-- ('array' . 'dimension' 'foldl'' . 'element')
-- @
--
-- You can use it like this:
--
-- @
-- vectorOfInts :: Value (Vector Int64)
-- vectorOfInts = 'foldableArray' ('nonNullable' 'int8')
-- @
--
-- 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 = array . dimension foldl' . element
-- * Array
-------------------------
{-|
Generic array encoder.
Here's an example of its usage:
@
someParamsEncoder :: 'Params' [[Int64]]
someParamsEncoder = 'param' ('nonNullable' ('array' ('dimension' 'foldl'' ('dimension' 'foldl'' ('element' ('nonNullable' 'int8'))))))
@
Please note that the PostgreSQL @IN@ keyword does not accept an array, but rather a syntactical list of
values, thus this encoder is not suited for that. Use a @value = ANY($1)@ condition instead.
-}
-- |
-- Generic array encoder.
--
-- Here's an example of its usage:
--
-- @
-- someParamsEncoder :: 'Params' [[Int64]]
-- someParamsEncoder = 'param' ('nonNullable' ('array' ('dimension' 'foldl'' ('dimension' 'foldl'' ('element' ('nonNullable' 'int8'))))))
-- @
--
-- Please note that the PostgreSQL @IN@ keyword does not accept an array, but rather a syntactical list of
-- values, thus this encoder is not suited for that. Use a @value = ANY($1)@ condition instead.
newtype Array a = Array (Array.Array a)
deriving (Contravariant)
{-|
Lifts a 'Value' encoder into an 'Array' encoder.
-}
-- |
-- Lifts a 'Value' encoder into an 'Array' encoder.
element :: NullableOrNot Value a -> Array a
element = \ case
element = \case
NonNullable (Value (Value.Value elementOID arrayOID encoder renderer)) ->
Array (Array.value elementOID arrayOID encoder renderer)
Nullable (Value (Value.Value elementOID arrayOID encoder renderer)) ->
Array (Array.nullableValue elementOID arrayOID encoder renderer)
{-|
Encoder of an array dimension,
which thus provides support for multidimensional arrays.
Accepts:
* An implementation of the left-fold operation,
such as @Data.Foldable.'foldl''@,
which determines the input value.
* A component encoder, which can be either another 'dimension' or 'element'.
-}
{-# INLINABLE dimension #-}
-- |
-- Encoder of an array dimension,
-- which thus provides support for multidimensional arrays.
--
-- Accepts:
--
-- * An implementation of the left-fold operation,
-- such as @Data.Foldable.'foldl''@,
-- which determines the input value.
--
-- * A component encoder, which can be either another 'dimension' or 'element'.
{-# INLINEABLE dimension #-}
dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c
dimension foldl (Array imp) = Array (Array.dimension foldl imp)

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

@ -1,17 +1,16 @@
module Hasql.Private.Encoders.Array where
import qualified Hasql.Private.PTI as B
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) (a -> C.Builder)
data Array a
= Array B.OID B.OID (Bool -> a -> A.Array) (a -> C.Builder)
instance Contravariant Array where
contramap fn (Array valueOid arrayOid encoder renderer) =
Array valueOid arrayOid (\ intDateTimes -> encoder intDateTimes . fn) (renderer . fn)
Array valueOid arrayOid (\intDateTimes -> encoder intDateTimes . fn) (renderer . fn)
{-# INLINE value #-}
value :: B.OID -> B.OID -> (Bool -> a -> A.Encoding) -> (a -> C.Builder) -> Array a
@ -21,29 +20,25 @@ value valueOID arrayOID encoder =
{-# INLINE nullableValue #-}
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
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 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
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

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

@ -1,17 +1,16 @@
module Hasql.Private.Encoders.Params where
import Hasql.Private.Prelude
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 Hasql.Private.Prelude
import qualified PostgreSQL.Binary.Encoding as B
import qualified Text.Builder as E
-- |
-- Encoder of some representation of a parameters product.
newtype Params a =
Params (Op (DList (A.Oid, A.Format, Bool -> Maybe ByteString, Text)) a)
newtype Params a
= Params (Op (DList (A.Oid, A.Format, Bool -> Maybe ByteString, Text)) a)
deriving (Contravariant, Divisible, Decidable, Semigroup, Monoid)
value :: C.Value a -> Params a
@ -20,12 +19,12 @@ value =
nullableValue :: C.Value a -> Params (Maybe a)
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)
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)

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

@ -1,13 +1,12 @@
module Hasql.Private.Encoders.Value where
import qualified Hasql.Private.PTI as PTI
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) (a -> C.Builder)
data Value a
= Value PTI.OID PTI.OID (Bool -> a -> B.Encoding) (a -> C.Builder)
instance Contravariant Value where
{-# INLINE contramap #-}

120
library/Hasql/Private/Errors.hs
View File

@ -1,90 +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
data QueryError
= QueryError ByteString [Text] CommandError
deriving (Show, Eq, Typeable)
instance Exception QueryError
-- |
-- 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
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 indexes of the row and column.
RowError Int Int RowError |
-- |
-- An unexpected amount of rows.
UnexpectedAmountOfRows Int
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 indexes of the row and column.
RowError Int 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
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)

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

@ -1,18 +1,16 @@
-- |
-- An API of low-level IO operations.
module Hasql.Private.IO
where
module Hasql.Private.IO where
import Hasql.Private.Prelude
import Hasql.Private.Errors
import qualified Data.DList as DList
import qualified Database.PostgreSQL.LibPQ as LibPQ
import qualified Hasql.Private.Commands as Commands
import qualified Hasql.Private.PreparedStatementRegistry as PreparedStatementRegistry
import qualified Hasql.Private.Decoders.Result as ResultDecoders
import qualified Hasql.Private.Decoders.Results as ResultsDecoders
import qualified Hasql.Private.Encoders.Params as ParamsEncoders
import qualified Data.DList as DList
import Hasql.Private.Errors
import Hasql.Private.Prelude
import qualified Hasql.Private.PreparedStatementRegistry as PreparedStatementRegistry
{-# INLINE acquireConnection #-}
acquireConnection :: ByteString -> IO LibPQ.Connection
@ -48,7 +46,7 @@ getIntegerDatetimes :: LibPQ.Connection -> IO Bool
getIntegerDatetimes c =
fmap decodeValue $ LibPQ.parameterStatus c "integer_datetimes"
where
decodeValue =
decodeValue =
\case
Just "on" -> True
_ -> False
@ -61,7 +59,7 @@ initConnection c =
{-# INLINE getResults #-}
getResults :: LibPQ.Connection -> Bool -> ResultsDecoders.Results a -> IO (Either CommandError a)
getResults connection integerDatetimes decoder =
{-# SCC "getResults" #-}
{-# SCC "getResults" #-}
(<*) <$> get <*> dropRemainders
where
get =
@ -71,11 +69,13 @@ getResults connection integerDatetimes decoder =
{-# INLINE getPreparedStatementKey #-}
getPreparedStatementKey ::
LibPQ.Connection -> PreparedStatementRegistry.PreparedStatementRegistry ->
ByteString -> [LibPQ.Oid] ->
LibPQ.Connection ->
PreparedStatementRegistry.PreparedStatementRegistry ->
ByteString ->
[LibPQ.Oid] ->
IO (Either CommandError ByteString)
getPreparedStatementKey connection registry template oidList =
{-# SCC "getPreparedStatementKey" #-}
{-# SCC "getPreparedStatementKey" #-}
PreparedStatementRegistry.update localKey onNewRemoteKey onOldRemoteKey registry
where
localKey =
@ -86,7 +86,7 @@ getPreparedStatementKey connection registry template oidList =
onNewRemoteKey key =
do
sent <- LibPQ.sendPrepare connection key template (mfilter (not . null) (Just oidList))
let resultsDecoder =
let resultsDecoder =
if sent
then ResultsDecoders.single ResultDecoders.noResult
else ResultsDecoders.clientError
@ -116,17 +116,15 @@ sendPreparedParametricStatement ::
a ->
IO (Either CommandError ())
sendPreparedParametricStatement 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
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 sendUnpreparedParametricStatement #-}
sendUnpreparedParametricStatement ::
@ -137,18 +135,16 @@ sendUnpreparedParametricStatement ::
a ->
IO (Either CommandError ())
sendUnpreparedParametricStatement 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
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 sendParametricStatement #-}
sendParametricStatement ::
LibPQ.Connection ->
Bool ->
Bool ->
PreparedStatementRegistry.PreparedStatementRegistry ->
ByteString ->
ParamsEncoders.Params a ->
@ -156,7 +152,7 @@ sendParametricStatement ::
a ->
IO (Either CommandError ())
sendParametricStatement connection integerDatetimes registry template encoder prepared params =
{-# SCC "sendParametricStatement" #-}
{-# SCC "sendParametricStatement" #-}
if prepared
then sendPreparedParametricStatement connection registry integerDatetimes template encoder params
else sendUnpreparedParametricStatement connection integerDatetimes template encoder params

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

@ -1,14 +1,13 @@
module Hasql.Private.PTI where
import Hasql.Private.Prelude hiding (bool)
import qualified Database.PostgreSQL.LibPQ as LibPQ
import Hasql.Private.Prelude hiding (bool)
-- | A Postgresql type info
data PTI = PTI { ptiOID :: !OID, ptiArrayOID :: !(Maybe OID) }
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, oidFormat :: !LibPQ.Format }
data OID = OID {oidWord32 :: !Word32, oidPQ :: !LibPQ.Oid, oidFormat :: !LibPQ.Format}
mkOID :: LibPQ.Format -> Word32 -> OID
mkOID format x =
@ -18,77 +17,144 @@ mkPTI :: LibPQ.Format -> Word32 -> Maybe Word32 -> PTI
mkPTI format oid arrayOID =
PTI (mkOID format oid) (fmap (mkOID format) arrayOID)
-- * Constants
-------------------------
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)
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)

128
library/Hasql/Private/Prelude.hs
View File

@ -1,36 +1,45 @@
module Hasql.Private.Prelude
(
module Exports,
LazyByteString,
ByteStringBuilder,
LazyText,
TextBuilder,
forMToZero_,
forMFromZero_,
strictCons,
mapLeft,
)
( module Exports,
LazyByteString,
ByteStringBuilder,
LazyText,
TextBuilder,
forMToZero_,
forMFromZero_,
strictCons,
mapLeft,
)
where
-- base
-------------------------
import Control.Applicative as Exports hiding (WrappedArrow(..))
import Control.Applicative as Exports hiding (WrappedArrow (..))
import Control.Arrow as Exports hiding (first, second)
import Control.Category as Exports
import Control.Concurrent as Exports
import Control.Exception as Exports
import Control.Monad as Exports hiding (fail, mapM_, sequence_, forM_, msum, mapM, sequence, forM)
import Control.Monad.IO.Class as Exports
import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_)
import Control.Monad.Error.Class as Exports (MonadError (..))
import Control.Monad.Fail as Exports
import Control.Monad.Fix as Exports hiding (fix)
import Control.Monad.IO.Class as Exports
import Control.Monad.Reader.Class as Exports (MonadReader (..))
import Control.Monad.ST as Exports
import Control.Monad.Trans.Class as Exports
import Control.Monad.Trans.Cont as Exports hiding (callCC, shift)
import Control.Monad.Trans.Except as Exports (Except, ExceptT (ExceptT), catchE, except, mapExcept, mapExceptT, runExcept, runExceptT, throwE, withExcept, withExceptT)
import Control.Monad.Trans.Maybe as Exports
import Control.Monad.Trans.Reader as Exports (Reader, ReaderT (ReaderT), mapReader, mapReaderT, runReader, runReaderT, withReader, withReaderT)
import Control.Monad.Trans.State.Strict as Exports (State, StateT (StateT), evalState, evalStateT, execState, execStateT, mapState, mapStateT, runState, runStateT, withState, withStateT)
import Control.Monad.Trans.Writer.Strict as Exports (Writer, WriterT (..), execWriter, execWriterT, mapWriter, mapWriterT, runWriter)
import Data.Bifunctor as Exports
import Data.Bits as Exports
import Data.Bool as Exports
import Data.ByteString as Exports (ByteString)
import qualified Data.ByteString.Builder
import qualified Data.ByteString.Lazy
import Data.Char as Exports
import Data.Coerce as Exports
import Data.Complex as Exports
import Data.DList as Exports (DList)
import Data.Data as Exports
import Data.Dynamic as Exports
import Data.Either as Exports
@ -40,22 +49,30 @@ import Data.Function as Exports hiding (id, (.))
import Data.Functor as Exports
import Data.Functor.Compose as Exports
import Data.Functor.Contravariant as Exports
import Data.Int as Exports
import Data.Functor.Contravariant.Divisible as Exports
import Data.Functor.Identity as Exports
import Data.Hashable as Exports (Hashable (..))
import Data.IORef as Exports
import Data.Int as Exports
import Data.Ix as Exports
import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')
import Data.List.NonEmpty as Exports (NonEmpty(..))
import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)
import Data.List.NonEmpty as Exports (NonEmpty (..))
import Data.Maybe as Exports
import Data.Monoid as Exports hiding (Alt, (<>))
import Data.Ord as Exports
import Data.Profunctor.Unsafe as Exports
import Data.Proxy as Exports
import Data.Ratio as Exports
import Data.Semigroup as Exports hiding (First(..), Last(..))
import Data.STRef as Exports
import Data.Semigroup as Exports hiding (First (..), Last (..))
import Data.String as Exports
import Data.Text as Exports (Text)
import qualified Data.Text.Lazy
import qualified Data.Text.Lazy.Builder
import Data.Traversable as Exports
import Data.Tuple as Exports
import Data.Unique as Exports
import Data.Vector as Exports (Vector)
import Data.Version as Exports
import Data.Void as Exports
import Data.Word as Exports
@ -64,13 +81,13 @@ import Foreign.ForeignPtr as Exports
import Foreign.Ptr as Exports
import Foreign.StablePtr as Exports
import Foreign.Storable as Exports
import GHC.Conc as Exports hiding (orElse, withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)
import GHC.Exts as Exports (IsList(..), lazy, inline, sortWith, groupWith)
import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)
import GHC.Exts as Exports (IsList (..), groupWith, inline, lazy, sortWith)
import GHC.Generics as Exports (Generic)
import GHC.IO.Exception as Exports
import GHC.OverloadedLabels as Exports
import Numeric as Exports
import Prelude as Exports hiding (Read, fail, concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.))
import PostgreSQL.Binary.Data as Exports (UUID)
import System.Environment as Exports
import System.Exit as Exports
import System.IO as Exports (Handle, hClose)
@ -80,67 +97,10 @@ import System.Mem as Exports
import System.Mem.StableName as Exports
import System.Timeout as Exports
import Text.ParserCombinators.ReadP as Exports (ReadP, readP_to_S, readS_to_P)
import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)
import Text.Printf as Exports (printf, hPrintf)
import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec)
import Text.Printf as Exports (hPrintf, printf)
import Unsafe.Coerce as Exports
-- transformers
-------------------------
import Control.Monad.IO.Class as Exports
import Control.Monad.Trans.Class as Exports
import Control.Monad.Trans.Cont as Exports hiding (shift, callCC)
import Control.Monad.Trans.Except as Exports (ExceptT(ExceptT), Except, except, runExcept, runExceptT, mapExcept, mapExceptT, withExcept, withExceptT, throwE, catchE)
import Control.Monad.Trans.Maybe as Exports
import Control.Monad.Trans.Reader as Exports (Reader, runReader, mapReader, withReader, ReaderT(ReaderT), runReaderT, mapReaderT, withReaderT)
import Control.Monad.Trans.State.Strict as Exports (State, runState, evalState, execState, mapState, withState, StateT(StateT), runStateT, evalStateT, execStateT, mapStateT, withStateT)
import Control.Monad.Trans.Writer.Strict as Exports (Writer, runWriter, execWriter, mapWriter, WriterT(..), execWriterT, mapWriterT)
import Data.Functor.Compose as Exports
import Data.Functor.Identity as Exports
-- mtl
-------------------------
import Control.Monad.Error.Class as Exports (MonadError (..))
import Control.Monad.Reader.Class as Exports (MonadReader (..))
-- profunctors
-------------------------
import Data.Profunctor.Unsafe as Exports
-- contravariant
-------------------------
import Data.Functor.Contravariant.Divisible as Exports
-- hashable
-------------------------
import Data.Hashable as Exports (Hashable(..))
-- text
-------------------------
import Data.Text as Exports (Text)
-- bytestring
-------------------------
import Data.ByteString as Exports (ByteString)
-- vector
-------------------------
import Data.Vector as Exports (Vector)
-- dlist
-------------------------
import Data.DList as Exports (DList)
-- postgresql-binary
-------------------------
import PostgreSQL.Binary.Data as Exports (UUID)
-- custom
-------------------------
import qualified Data.Text.Lazy
import qualified Data.Text.Lazy.Builder
import qualified Data.ByteString.Lazy
import qualified Data.ByteString.Builder
import Prelude as Exports hiding (Read, all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.))
type LazyByteString =
Data.ByteString.Lazy.ByteString

29
library/Hasql/Private/PreparedStatementRegistry.hs
View File

@ -1,26 +1,24 @@
module Hasql.Private.PreparedStatementRegistry
(
PreparedStatementRegistry,
new,
update,
LocalKey(..),
)
( PreparedStatementRegistry,
new,
update,
LocalKey (..),
)
where
import Hasql.Private.Prelude hiding (lookup)
import qualified Data.HashTable.IO as A
import qualified ByteString.StrictBuilder as B
import qualified Data.HashTable.IO as A
import Hasql.Private.Prelude hiding (lookup)
data PreparedStatementRegistry
= PreparedStatementRegistry !(A.BasicHashTable LocalKey ByteString) !(IORef Word)
data PreparedStatementRegistry =
PreparedStatementRegistry !(A.BasicHashTable LocalKey ByteString) !(IORef Word)
{-# INLINABLE new #-}
{-# INLINEABLE new #-}
new :: IO PreparedStatementRegistry
new =
PreparedStatementRegistry <$> A.new <*> newIORef 0
{-# INLINABLE update #-}
{-# INLINEABLE update #-}
update :: LocalKey -> (ByteString -> IO (Bool, a)) -> (ByteString -> IO a) -> PreparedStatementRegistry -> IO a
update localKey onNewRemoteKey onOldRemoteKey (PreparedStatementRegistry table counter) =
lookup >>= maybe new old
@ -43,11 +41,10 @@ update localKey onNewRemoteKey onOldRemoteKey (PreparedStatementRegistry table c
old =
onOldRemoteKey
-- |
-- Local statement key.
data LocalKey =
LocalKey !ByteString ![Word32]
data LocalKey
= LocalKey !ByteString ![Word32]
deriving (Show, Eq)
instance Hashable LocalKey where

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

@ -1,23 +1,21 @@
module Hasql.Private.Session
where
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.Encoders as Encoders
import qualified Hasql.Private.Settings as Settings
import qualified Hasql.Private.IO as IO
import qualified Hasql.Statement as Statement
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
import qualified Hasql.Private.Encoders as Encoders
import qualified Hasql.Private.Encoders.Params as Encoders.Params
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
-- |
-- A batch of actions to be executed in the context of a database connection.
newtype Session a =
Session (ReaderT Connection.Connection (ExceptT QueryError IO) a)
newtype Session a
= Session (ReaderT Connection.Connection (ExceptT QueryError IO) a)
deriving (Functor, Applicative, Monad, MonadError QueryError, MonadIO, MonadReader Connection.Connection)
-- |
@ -25,7 +23,7 @@ newtype Session a =
run :: Session a -> Connection.Connection -> IO (Either QueryError a)
run (Session impl) connection =
runExceptT $
runReaderT impl connection
runReaderT impl connection
-- |
-- Possibly a multi-statement query,
@ -33,11 +31,14 @@ run (Session impl) connection =
-- 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
@ -46,15 +47,17 @@ sql sql =
-- 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
step (_, _, _, rendering) acc =
rendering : acc
in foldr step [] (encoderOp input)
let Encoders.Params.Params (Op encoderOp) = paramsEncoder
step (_, _, _, rendering) acc =
rendering : acc
in foldr step [] (encoderOp input)

42
library/Hasql/Private/Settings.hs
View File

@ -1,14 +1,12 @@
module Hasql.Private.Settings where
import Hasql.Private.Prelude
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as BL
import Hasql.Private.Prelude
-- |
-- All settings encoded in a single byte-string according to
-- |
-- All settings encoded in a single byte-string according to
-- <http://www.postgresql.org/docs/9.4/static/libpq-connect.html#LIBPQ-CONNSTRING the PostgreSQL format>.
type Settings =
ByteString
@ -18,21 +16,19 @@ type Settings =
{-# 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)
]

21
library/Hasql/Session.hs
View File

@ -1,14 +1,15 @@
module Hasql.Session
(
Session,
sql,
statement,
-- * Execution
run,
-- * Errors
module Hasql.Private.Errors,
)
( Session,
sql,
statement,
-- * Execution
run,
-- * Errors
module Hasql.Private.Errors,
)
where
import Hasql.Private.Session
import Hasql.Private.Errors
import Hasql.Private.Session

195
library/Hasql/Statement.hs
View File

@ -1,57 +1,56 @@
module Hasql.Statement
(
Statement(..),
refineResult,
-- * Recipies
( Statement (..),
refineResult,
-- ** Insert many
-- $insertMany
-- * Recipies
-- ** IN and NOT IN
-- $inAndNotIn
)
-- ** Insert many
-- $insertMany
-- ** IN and NOT IN
-- $inAndNotIn
)
where
import Hasql.Private.Prelude
import qualified Hasql.Decoders as Decoders
import qualified Hasql.Encoders as Encoders
import qualified Hasql.Private.Decoders as Decoders
import Hasql.Private.Prelude
{-|
Specification of a strictly single-statement query, which can be parameterized and prepared.
Consists of the following:
* SQL template,
* params encoder,
* result decoder,
* a flag, determining whether it should be prepared.
The SQL template must be formatted according to Postgres' standard,
with any non-ASCII characters of the template encoded using UTF-8.
According to the format,
parameters must be referred to using a positional notation, as in the following:
@$1@, @$2@, @$3@ and etc.
Those references must be used in accordance with the order in which
the value encoders are specified in 'Encoders.Params'.
Following is an example of a declaration of a prepared statement with its associated codecs.
@
selectSum :: 'Statement' (Int64, Int64) Int64
selectSum = 'Statement' sql encoder decoder True where
sql = "select ($1 + $2)"
encoder =
('fst' '>$<' Encoders.'Hasql.Encoders.param' (Encoders.'Hasql.Encoders.nonNullable' Encoders.'Hasql.Encoders.int8')) '<>'
('snd' '>$<' Encoders.'Hasql.Encoders.param' (Encoders.'Hasql.Encoders.nonNullable' Encoders.'Hasql.Encoders.int8'))
decoder = Decoders.'Hasql.Decoders.singleRow' (Decoders.'Hasql.Decoders.column' (Decoders.'Hasql.Decoders.nonNullable' Decoders.'Hasql.Decoders.int8'))
@
The statement above accepts a product of two parameters of type 'Int64'
and produces a single result of type 'Int64'.
-}
data Statement a b =
Statement ByteString (Encoders.Params a) (Decoders.Result b) Bool
-- |
-- Specification of a strictly single-statement query, which can be parameterized and prepared.
--
-- Consists of the following:
--
-- * SQL template,
-- * params encoder,
-- * result decoder,
-- * a flag, determining whether it should be prepared.
--
-- The SQL template must be formatted according to Postgres' standard,
-- with any non-ASCII characters of the template encoded using UTF-8.
-- According to the format,
-- parameters must be referred to using a positional notation, as in the following:
-- @$1@, @$2@, @$3@ and etc.
-- Those references must be used in accordance with the order in which
-- the value encoders are specified in 'Encoders.Params'.
--
-- Following is an example of a declaration of a prepared statement with its associated codecs.
--
-- @
-- selectSum :: 'Statement' (Int64, Int64) Int64
-- selectSum = 'Statement' sql encoder decoder True where
-- sql = "select ($1 + $2)"
-- encoder =
-- ('fst' '>$<' Encoders.'Hasql.Encoders.param' (Encoders.'Hasql.Encoders.nonNullable' Encoders.'Hasql.Encoders.int8')) '<>'
-- ('snd' '>$<' Encoders.'Hasql.Encoders.param' (Encoders.'Hasql.Encoders.nonNullable' Encoders.'Hasql.Encoders.int8'))
-- decoder = Decoders.'Hasql.Decoders.singleRow' (Decoders.'Hasql.Decoders.column' (Decoders.'Hasql.Decoders.nonNullable' Decoders.'Hasql.Decoders.int8'))
-- @
--
-- The statement above accepts a product of two parameters of type 'Int64'
-- and produces a single result of type 'Int64'.
data Statement a b
= Statement ByteString (Encoders.Params a) (Decoders.Result b) Bool
instance Functor (Statement a) where
{-# INLINE fmap #-}
@ -62,63 +61,59 @@ instance Profunctor Statement where
dimap f1 f2 (Statement template encoder decoder preparable) =
Statement template (contramap f1 encoder) (fmap f2 decoder) preparable
{-|
Refine a result of a statement,
causing the running session to fail with the `UnexpectedResult` error in case of refinement failure.
This function is especially useful for refining the results of statements produced with
<http://hackage.haskell.org/package/hasql-th the \"hasql-th\" library>.
-}
-- |
-- Refine a result of a statement,
-- causing the running session to fail with the `UnexpectedResult` error in case of refinement failure.
--
-- This function is especially useful for refining the results of statements produced with
-- <http://hackage.haskell.org/package/hasql-th the \"hasql-th\" library>.
refineResult :: (a -> Either Text b) -> Statement params a -> Statement params b
refineResult refiner (Statement template encoder decoder preparable) =
Statement template encoder (Decoders.refineResult refiner decoder) preparable
-- $insertMany
--
-- It is not currently possible to pass in an array of encodable values
-- to use in an insert many statement. Instead, PostgreSQL's
-- (9.4 or later) @unnest@ function can be used in an analogous way
-- to haskell's `zip` function by passing in multiple arrays of values
-- to be zipped into the rows we want to insert:
--
-- @
-- insertMultipleLocations :: 'Statement' (Vector (UUID, Double, Double)) ()
-- insertMultipleLocations = 'Statement' sql encoder decoder True where
-- sql = "insert into location (id, x, y) select * from unnest ($1, $2, $3)"
-- encoder =
-- contramap Vector.'Data.Vector.unzip3' $
-- contrazip3 (vector Encoders.'Encoders.uuid') (vector Encoders.'Encoders.float8') (vector Encoders.'Encoders.float8')
-- where
-- vector =
-- Encoders.'Encoders.param' .
-- Encoders.'Encoders.nonNullable' .
-- Encoders.'Encoders.array' .
-- Encoders.'Encoders.dimension' 'foldl'' .
-- Encoders.'Encoders.element' .
-- Encoders.'Encoders.nonNullable'
-- decoder = Decoders.'Decoders.noResult'
-- @
--
-- This approach is much more efficient than executing a single-row Insert
-- statement multiple times.
{- $insertMany
It is not currently possible to pass in an array of encodable values
to use in an insert many statement. Instead, PostgreSQL's
(9.4 or later) @unnest@ function can be used in an analogous way
to haskell's `zip` function by passing in multiple arrays of values
to be zipped into the rows we want to insert:
@
insertMultipleLocations :: 'Statement' (Vector (UUID, Double, Double)) ()
insertMultipleLocations = 'Statement' sql encoder decoder True where
sql = "insert into location (id, x, y) select * from unnest ($1, $2, $3)"
encoder =
contramap Vector.'Data.Vector.unzip3' $
contrazip3 (vector Encoders.'Encoders.uuid') (vector Encoders.'Encoders.float8') (vector Encoders.'Encoders.float8')
where
vector =
Encoders.'Encoders.param' .
Encoders.'Encoders.nonNullable' .
Encoders.'Encoders.array' .
Encoders.'Encoders.dimension' 'foldl'' .
Encoders.'Encoders.element' .
Encoders.'Encoders.nonNullable'
decoder = Decoders.'Decoders.noResult'
@
This approach is much more efficient than executing a single-row Insert
statement multiple times.
-}
{- $inAndNotIn
There is a common misconception that Postgresql supports array
as a parameter for the @IN@ operator.
However Postgres only supports a syntactical list of values with it,
i.e., you have to specify each option as an individual parameter
(@something IN ($1, $2, $3)@).
Clearly it would be much more convenient to provide an array as a single parameter,
but the @IN@ operator does not support that.
Fortunately, Postgres does provide such functionality with other operators:
* Use @something = ANY($1)@ instead of @something IN ($1)@
* Use @something <> ALL($1)@ instead of @something NOT IN ($1)@
For details see
<https://www.postgresql.org/docs/9.6/static/functions-comparisons.html#AEN20944 the Postgresql docs>.
-}
-- $inAndNotIn
--
-- There is a common misconception that Postgresql supports array
-- as a parameter for the @IN@ operator.
-- However Postgres only supports a syntactical list of values with it,
-- i.e., you have to specify each option as an individual parameter
-- (@something IN ($1, $2, $3)@).
--
-- Clearly it would be much more convenient to provide an array as a single parameter,
-- but the @IN@ operator does not support that.
-- Fortunately, Postgres does provide such functionality with other operators:
--
-- * Use @something = ANY($1)@ instead of @something IN ($1)@
-- * Use @something <> ALL($1)@ instead of @something NOT IN ($1)@
--
-- For details see
-- <https://www.postgresql.org/docs/9.6/static/functions-comparisons.html#AEN20944 the Postgresql docs>.

13
profiling/Main.hs
View File

@ -1,13 +1,12 @@
module Main where
import Prelude
import qualified Data.Vector as F
import qualified Hasql.Connection as A
import qualified Hasql.Session as B
import qualified Hasql.Statement as C
import qualified Hasql.Decoders as D
import qualified Hasql.Encoders as E
import qualified Data.Vector as F
import qualified Hasql.Session as B
import qualified Hasql.Statement as C
import Prelude
main =
do
@ -29,9 +28,7 @@ main =
password = ""
database = "postgres"
-- * Sessions
-------------------------
sessionWithManySmallParameters :: Vector (Int64, Int64) -> B.Session ()
sessionWithManySmallParameters =
@ -49,9 +46,7 @@ sessionWithManySmallResults :: B.Session (Vector (Int64, Int64))
sessionWithManySmallResults =
F.replicateM 1000 (B.statement () statementWithSingleRow)
-- * Statements
-------------------------
statementWithManyParameters :: C.Statement (Vector (Int64, Int64)) ()
statementWithManyParameters =

870
tasty/Main.hs
View File

@ -1,488 +1,434 @@
module Main where
import Contravariant.Extras
import qualified Hasql.Decoders as Decoders
import qualified Hasql.Encoders as Encoders
import qualified Hasql.Session as Session
import qualified Hasql.Statement as Statement
import qualified Main.Connection as Connection
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.Tasty
import Test.Tasty.Runners
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
import Contravariant.Extras
import qualified Test.QuickCheck as QuickCheck
import qualified Main.Statements as Statements
import qualified Main.DSL as DSL
import qualified Main.Connection as Connection
import qualified Hasql.Statement as Statement
import qualified Hasql.Encoders as Encoders
import qualified Hasql.Decoders as Decoders
import qualified Hasql.Session as Session
import Test.Tasty.Runners
main =
defaultMain tree
tree =
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
,
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 =
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 array[]::int8[]"
"select (1, true)"
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
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
statement =
Statement.Statement sql encoder decoder True
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
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
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,
testCase "Empty array" $
let io =
do
x <- Connection.with (Session.run session)
assertEqual (show x) (Right (Right [])) x
where
statement =
Statement.Statement sql encoder decoder True
session =
Session.statement () statement
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
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
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"
createTable =
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')"
deleteRows =
DSL.statement () $ Statement.Statement sql mempty decoder False
where
sql =
"delete from a"
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
]
dropTable =
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))"
insertRow =
DSL.statement () $
Statements.plain $
"insert into a (name) values ('a')"
deleteRows =
DSL.statement () $ Statement.Statement sql mempty decoder False
where
sql =
"delete from a"
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
]

8
tasty/Main/Connection.hs
View File

@ -1,11 +1,9 @@
module Main.Connection
where
module Main.Connection where
import Main.Prelude
import qualified Hasql.Connection as HC
import qualified Hasql.Statement as HQ
import qualified Hasql.Session
import qualified Hasql.Statement as HQ
import Main.Prelude
with :: (HC.Connection -> IO a) -> IO (Either HC.ConnectionError a)
with handler =

30
tasty/Main/DSL.hs
View File

@ -1,27 +1,25 @@
module Main.DSL
(
Session,
SessionError(..),
session,
Hasql.Session.statement,
Hasql.Session.sql,
)
( Session,
SessionError (..),
session,
Hasql.Session.statement,
Hasql.Session.sql,
)
where
import Main.Prelude
import qualified Hasql.Connection as HC
import qualified Hasql.Statement as HQ
import qualified Hasql.Encoders as HE
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 =
Hasql.Session.Session
data SessionError =
ConnectionError (HC.ConnectionError) |
SessionError (Hasql.Session.QueryError)
data SessionError
= ConnectionError (HC.ConnectionError)
| SessionError (Hasql.Session.QueryError)
deriving (Show, Eq)
session :: Session a -> IO (Either SessionError a)
@ -41,7 +39,7 @@ session session =
database = "postgres"
use connection =
ExceptT $
fmap (mapLeft SessionError) $
Hasql.Session.run session connection
fmap (mapLeft SessionError) $
Hasql.Session.run session connection
release connection =
lift $ HC.release connection

8
tasty/Main/Prelude.hs
View File

@ -1,10 +1,6 @@
module Main.Prelude
(
module Exports,
)
( module Exports,
)
where
-- rerebase
-------------------------
import Prelude as Exports

12
tasty/Main/Statements.hs
View File

@ -1,12 +1,11 @@
module Main.Statements where
import Main.Prelude
import qualified Hasql.Statement as HQ
import qualified Hasql.Encoders as HE
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 =
HQ.Statement sql mempty HD.noResult False
@ -19,8 +18,9 @@ dropType name =
createEnum :: ByteString -> [ByteString] -> HQ.Statement () ()
createEnum name values =
plain $
"create type " <> name <> " as enum (" <>
mconcat (intersperse ", " (map (\x -> "'" <> x <> "'") values)) <> ")"
"create type " <> name <> " as enum ("
<> mconcat (intersperse ", " (map (\x -> "'" <> x <> "'") values))
<> ")"
selectList :: HQ.Statement () ([] (Int64, Int64))
selectList =

15
threads-test/Main.hs
View File

@ -1,13 +1,12 @@
module Main where
import Prelude
import qualified Hasql.Connection
import qualified Hasql.Statement
import qualified Hasql.Encoders
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 =
acquire >>= use
@ -17,8 +16,8 @@ main =
where
acquire =
join $
fmap (either (fail . show) return) $
Hasql.Connection.acquire connectionSettings
fmap (either (fail . show) return) $
Hasql.Connection.acquire connectionSettings
where
connectionSettings =
Hasql.Connection.settings "localhost" 5432 "postgres" "" "postgres"
@ -41,5 +40,5 @@ main =
bool exitFailure exitSuccess . traceShowId =<< takeMVar finishVar
where
session connection session =
Hasql.Session.run session connection >>=
either (fail . show) return
Hasql.Session.run session connection
>>= either (fail . show) return

9
threads-test/Main/Statements.hs
View File

@ -1,10 +1,9 @@
module Main.Statements where
import Prelude
import Hasql.Statement
import qualified Hasql.Encoders as E
import qualified Hasql.Decoders as D
import qualified Hasql.Encoders as E
import Hasql.Statement
import Prelude
selectSleep :: Statement Double ()
selectSleep =
@ -16,5 +15,3 @@ selectSleep =
E.param (E.nonNullable E.float8)
decoder =
D.noResult