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

Redesign the codecs, updating the docs

Browse Source
This commit is contained in:
Nikita Volkov 2019-05-28 09:29:45 +03:00
commit 956bde980c
19 changed files with 1055 additions and 1306 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
README.md
View File

@ -100,19 +100,19 @@ sumStatement :: Statement (Int64, Int64) Int64
sumStatement = Statement sql encoder decoder True where
sql = "select $1 + $2"
encoder =
(fst >$< Encoders.param Encoders.int8) <>
(snd >$< Encoders.param Encoders.int8)
decoder = Decoders.singleRow (Decoders.column Decoders.int8)
(fst >$< Encoders.param (Encoders.nonNullable Encoders.int8)) <>
(snd >$< Encoders.param (Encoders.nonNullable Encoders.int8))
decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8))
divModStatement :: Statement (Int64, Int64) (Int64, Int64)
divModStatement = Statement sql encoder decoder True where
sql = "select $1 / $2, $1 % $2"
encoder =
(fst >$< Encoders.param Encoders.int8) <>
(snd >$< Encoders.param Encoders.int8)
(fst >$< Encoders.param (Encoders.nonNullable Encoders.int8)) <>
(snd >$< Encoders.param (Encoders.nonNullable Encoders.int8))
decoder = Decoders.singleRow row where
row =
(,) <$>
Decoders.column Decoders.int8 <*>
Decoders.column Decoders.int8
Decoders.column (Decoders.nonNullable Decoders.int8) <*>
Decoders.column (Decoders.nonNullable Decoders.int8)
```

4
benchmarks/Main.hs
View File

@ -79,7 +79,7 @@ statementWithSingleRow =
D.singleRow row
where
row =
tuple <$> D.column D.int8 <*> D.column D.int8
tuple <$> (D.column . D.nonNullable) D.int8 <*> (D.column . D.nonNullable) D.int8
where
tuple !a !b =
(a, b)
@ -93,7 +93,7 @@ statementWithManyRows decoder =
encoder =
conquer
rowDecoder =
tuple <$> D.column D.int8 <*> D.column D.int8
tuple <$> (D.column . D.nonNullable) D.int8 <*> (D.column . D.nonNullable) D.int8
where
tuple !a !b =
(a, b)

6
hasql.cabal
View File

@ -1,5 +1,5 @@
name: hasql
version: 1.3.0.6
version: 1.4
category: Hasql, Database, PostgreSQL
synopsis: An efficient PostgreSQL driver with a flexible mapping API
description:
@ -40,12 +40,14 @@ library
Hasql.Private.PreparedStatementRegistry
Hasql.Private.Settings
Hasql.Private.Commands
Hasql.Private.Decoders
Hasql.Private.Decoders.Array
Hasql.Private.Decoders.Composite
Hasql.Private.Decoders.Value
Hasql.Private.Decoders.Row
Hasql.Private.Decoders.Result
Hasql.Private.Decoders.Results
Hasql.Private.Encoders
Hasql.Private.Encoders.Array
Hasql.Private.Encoders.Value
Hasql.Private.Encoders.Params
@ -57,7 +59,6 @@ library
bytestring-strict-builder >=0.4.5.1 && <0.5,
contravariant >=1.3 && <2,
contravariant-extras ==0.3.*,
data-default-class >=0.0.1 && <0.2,
dlist >=0.7 && <0.9,
hashable >=1.2 && <2,
hashtables >=1.1 && <2,
@ -84,7 +85,6 @@ test-suite tasty
Main.Statements
Main.Prelude
build-depends:
data-default-class,
hasql,
QuickCheck >=2.8.1 && <3,
quickcheck-instances >=0.3.11 && <0.4,

669
library/Hasql/Decoders.hs
View File

@ -1,10 +1,11 @@
-- |
-- A DSL for declaration of result decoders.
{-|
A DSL for declaration of result decoders.
-}
module Hasql.Decoders
(
-- * Result
Result,
unit,
noResult,
rowsAffected,
singleRow,
-- ** Specialized multi-row results
@ -17,7 +18,10 @@ module Hasql.Decoders
-- * Row
Row,
column,
nullableColumn,
-- * Nullability
NullableOrNot,
nonNullable,
nullable,
-- * Value
Value,
bool,
@ -43,6 +47,8 @@ module Hasql.Decoders
jsonb,
jsonbBytes,
array,
listArray,
vectorArray,
composite,
hstore,
enum,
@ -51,663 +57,10 @@ module Hasql.Decoders
Array,
dimension,
element,
nullableElement,
-- * Composite
Composite,
field,
nullableField,
)
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 Hasql.Private.Decoders.Array as Array
import qualified Hasql.Private.Decoders.Composite as Composite
import qualified Hasql.Private.Prelude as Prelude
-- * 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 unit #-}
unit :: Result ()
unit =
Result (Results.single Result.unit)
-- |
-- Get the amount of rows affected by such statements as
-- @UPDATE@ or @DELETE@.
--
{-# INLINABLE rowsAffected #-}
rowsAffected :: Result Int64
rowsAffected =
Result (Results.single Result.rowsAffected)
-- |
-- Exactly one row.
-- Will raise the 'Hasql.Errors.UnexpectedAmountOfRows' error if it's any other.
--
{-# INLINABLE singleRow #-}
singleRow :: Row a -> Result a
singleRow (Row row) =
Result (Results.single (Result.single row))
-- ** Multi-row traversers
-------------------------
-- |
-- Foldl multiple rows.
--
{-# INLINABLE 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 #-}
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 #-}
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 #-}
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 #-}
rowList :: Row a -> Result [a]
rowList =
foldrRows strictCons []
-- ** Instances
-------------------------
-- | Maps to 'unit'.
instance Default (Result ()) where
{-# INLINE def #-}
def =
unit
-- | Maps to 'rowsAffected'.
instance Default (Result Int64) where
{-# INLINE def #-}
def =
rowsAffected
-- | Maps to @('rowMaybe' def)@.
instance Default (Row a) => Default (Result (Maybe a)) where
{-# INLINE def #-}
def =
rowMaybe def
-- | Maps to @('rowVector' def)@.
instance Default (Row a) => Default (Result (Vector a)) where
{-# INLINE def #-}
def =
rowVector def
-- | Maps to @('rowList' def)@.
instance Default (Row a) => Default (Result ([] a)) where
{-# INLINE def #-}
def =
rowList def
-- | Maps to @(fmap Identity ('singleRow' def)@.
instance Default (Row a) => Default (Result (Identity a)) where
{-# INLINE def #-}
def =
fmap Identity (singleRow def)
-- * Row
-------------------------
-- |
-- Decoder of an individual row,
-- which gets composed of column value decoders.
--
-- E.g.:
--
-- >x :: Row (Maybe Int64, Text, TimeOfDay)
-- >x =
-- > (,,) <$> nullableColumn int8 <*> column text <*> column time
--
newtype Row a =
Row (Row.Row a)
deriving (Functor, Applicative, Monad)
-- |
-- Lift an individual non-nullable value decoder to a composable row decoder.
--
{-# INLINABLE column #-}
column :: Value a -> Row a
column (Value imp) =
Row (Row.nonNullValue imp)
-- |
-- Lift an individual nullable value decoder to a composable row decoder.
--
{-# INLINABLE nullableColumn #-}
nullableColumn :: Value a -> Row (Maybe a)
nullableColumn (Value imp) =
Row (Row.value imp)
-- ** Instances
-------------------------
instance Default (Value a) => Default (Row (Identity a)) where
{-# INLINE def #-}
def =
fmap Identity (column def)
instance Default (Value a) => Default (Row (Maybe a)) where
{-# INLINE def #-}
def =
nullableColumn def
instance (Default (Value a1), Default (Value a2)) => Default (Row (a1, a2)) where
{-# INLINE def #-}
def =
ap (fmap (,) (column def)) (column def)
-- * Value
-------------------------
-- |
-- Decoder of an individual value.
--
newtype Value a =
Value (Value.Value a)
deriving (Functor)
-- ** Plain value decoders
-------------------------
-- |
-- Decoder of the @BOOL@ values.
--
{-# INLINABLE bool #-}
bool :: Value Bool
bool =
Value (Value.decoder (const A.bool))
-- |
-- Decoder of the @INT2@ values.
--
{-# INLINABLE int2 #-}
int2 :: Value Int16
int2 =
Value (Value.decoder (const A.int))
-- |
-- Decoder of the @INT4@ values.
--
{-# INLINABLE int4 #-}
int4 :: Value Int32
int4 =
Value (Value.decoder (const A.int))
-- |
-- Decoder of the @INT8@ values.
--
{-# INLINABLE int8 #-}
int8 :: Value Int64
int8 =
{-# SCC "int8" #-}
Value (Value.decoder (const ({-# SCC "int8.int" #-} A.int)))
-- |
-- Decoder of the @FLOAT4@ values.
--
{-# INLINABLE float4 #-}
float4 :: Value Float
float4 =
Value (Value.decoder (const A.float4))
-- |
-- Decoder of the @FLOAT8@ values.
--
{-# INLINABLE float8 #-}
float8 :: Value Double
float8 =
Value (Value.decoder (const A.float8))
-- |
-- Decoder of the @NUMERIC@ values.
--
{-# INLINABLE numeric #-}
numeric :: Value B.Scientific
numeric =
Value (Value.decoder (const A.numeric))
-- |
-- Decoder of the @CHAR@ values.
-- Note that it supports UTF-8 values.
{-# INLINABLE char #-}
char :: Value Char
char =
Value (Value.decoder (const A.char))
-- |
-- Decoder of the @TEXT@ values.
--
{-# INLINABLE text #-}
text :: Value Text
text =
Value (Value.decoder (const A.text_strict))
-- |
-- Decoder of the @BYTEA@ values.
--
{-# INLINABLE bytea #-}
bytea :: Value ByteString
bytea =
Value (Value.decoder (const A.bytea_strict))
-- |
-- Decoder of the @DATE@ values.
--
{-# INLINABLE date #-}
date :: Value B.Day
date =
Value (Value.decoder (const A.date))
-- |
-- Decoder of the @TIMESTAMP@ values.
--
{-# INLINABLE 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 #-}
timestamptz :: Value B.UTCTime
timestamptz =
Value (Value.decoder (Prelude.bool A.timestamptz_float A.timestamptz_int))
-- |
-- Decoder of the @TIME@ values.
--
{-# INLINABLE 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 #-}
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 #-}
interval :: Value B.DiffTime
interval =
Value (Value.decoder (Prelude.bool A.interval_float A.interval_int))
-- |
-- Decoder of the @UUID@ values.
--
{-# INLINABLE uuid #-}
uuid :: Value B.UUID
uuid =
Value (Value.decoder (const A.uuid))
-- |
-- Decoder of the @INET@ values.
--
{-# INLINABLE 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 #-}
json :: Value B.Value
json =
Value (Value.decoder (const A.json_ast))
-- |
-- Decoder of the @JSON@ values into a raw JSON 'ByteString'.
--
{-# INLINABLE 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 #-}
jsonb :: Value B.Value
jsonb =
Value (Value.decoder (const A.jsonb_ast))
-- |
-- Decoder of the @JSONB@ values into a raw JSON 'ByteString'.
--
{-# INLINABLE jsonbBytes #-}
jsonbBytes :: (ByteString -> Either Text a) -> Value a
jsonbBytes fn =
Value (Value.decoder (const (A.jsonb_bytes fn)))
-- |
-- Lifts a custom value decoder function to a 'Value' decoder.
--
{-# INLINABLE custom #-}
custom :: (Bool -> ByteString -> Either Text a) -> Value a
custom fn =
Value (Value.decoderFn fn)
-- ** Composite value decoders
-------------------------
-- |
-- Lifts the 'Array' decoder to the 'Value' decoder.
--
{-# INLINABLE array #-}
array :: Array a -> Value a
array (Array imp) =
Value (Value.decoder (Array.run imp))
-- |
-- Lifts the 'Composite' decoder to the 'Value' decoder.
--
{-# INLINABLE composite #-}
composite :: Composite a -> Value a
composite (Composite imp) =
Value (Value.decoder (Composite.run imp))
-- |
-- 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 #-}
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.
enum :: (Text -> Maybe a) -> Value a
enum mapping =
Value (Value.decoder (const (A.enum mapping)))
-- ** Instances
-------------------------
-- |
-- Maps to 'bool'.
instance Default (Value Bool) where
{-# INLINE def #-}
def =
bool
-- |
-- Maps to 'int2'.
instance Default (Value Int16) where
{-# INLINE def #-}
def =
int2
-- |
-- Maps to 'int4'.
instance Default (Value Int32) where
{-# INLINE def #-}
def =
int4
-- |
-- Maps to 'int8'.
instance Default (Value Int64) where
{-# INLINE def #-}
def =
int8
-- |
-- Maps to 'float4'.
instance Default (Value Float) where
{-# INLINE def #-}
def =
float4
-- |
-- Maps to 'float8'.
instance Default (Value Double) where
{-# INLINE def #-}
def =
float8
-- |
-- Maps to 'numeric'.
instance Default (Value B.Scientific) where
{-# INLINE def #-}
def =
numeric
-- |
-- Maps to 'char'.
instance Default (Value Char) where
{-# INLINE def #-}
def =
char
-- |
-- Maps to 'text'.
instance Default (Value Text) where
{-# INLINE def #-}
def =
text
-- |
-- Maps to 'bytea'.
instance Default (Value ByteString) where
{-# INLINE def #-}
def =
bytea
-- |
-- Maps to 'date'.
instance Default (Value B.Day) where
{-# INLINE def #-}
def =
date
-- |
-- Maps to 'timestamp'.
instance Default (Value B.LocalTime) where
{-# INLINE def #-}
def =
timestamp
-- |
-- Maps to 'timestamptz'.
instance Default (Value B.UTCTime) where
{-# INLINE def #-}
def =
timestamptz
-- |
-- Maps to 'time'.
instance Default (Value B.TimeOfDay) where
{-# INLINE def #-}
def =
time
-- |
-- Maps to 'timetz'.
instance Default (Value (B.TimeOfDay, B.TimeZone)) where
{-# INLINE def #-}
def =
timetz
-- |
-- Maps to 'interval'.
instance Default (Value B.DiffTime) where
{-# INLINE def #-}
def =
interval
-- |
-- Maps to 'uuid'.
instance Default (Value B.UUID) where
{-# INLINE def #-}
def =
uuid
-- |
-- Maps to 'json'.
instance Default (Value B.Value) where
{-# INLINE def #-}
def =
json
-- * 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 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',
-- 'element' or 'nullableElement'.
--
{-# INLINABLE 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 non-nullable leaf values.
{-# INLINABLE element #-}
element :: Value a -> Array a
element (Value imp) =
Array (Array.nonNullValue (Value.run imp))
-- |
-- Lift a 'Value' decoder into an 'Array' decoder for parsing of nullable leaf values.
{-# INLINABLE nullableElement #-}
nullableElement :: Value a -> Array (Maybe a)
nullableElement (Value imp) =
Array (Array.value (Value.run imp))
-- * Composite decoders
-------------------------
-- |
-- Composable decoder of composite values (rows, records).
newtype Composite a =
Composite (Composite.Composite a)
deriving (Functor, Applicative, Monad)
-- |
-- Lift a 'Value' decoder into a 'Composite' decoder for parsing of non-nullable leaf values.
{-# INLINABLE field #-}
field :: Value a -> Composite a
field (Value imp) =
Composite (Composite.nonNullValue (Value.run imp))
-- |
-- Lift a 'Value' decoder into a 'Composite' decoder for parsing of nullable leaf values.
{-# INLINABLE nullableField #-}
nullableField :: Value a -> Composite (Maybe a)
nullableField (Value imp) =
Composite (Composite.value (Value.run imp))
import Hasql.Private.Decoders

537
library/Hasql/Encoders.hs
View File

@ -1,12 +1,19 @@
-- |
-- A DSL for declaration of query parameter encoders.
{-|
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
(
-- * Params
-- * Parameters product
Params,
unit,
noParams,
param,
nullableParam,
-- * Nullability
NullableOrNot,
nonNullable,
nullable,
-- * Value
Value,
bool,
@ -31,529 +38,15 @@ module Hasql.Encoders
jsonBytes,
jsonb,
jsonbBytes,
array,
enum,
unknown,
array,
foldableArray,
-- * Array
Array,
element,
nullableElement,
dimension,
-- ** Insert Many
-- $insertMany
)
where
import Hasql.Private.Prelude hiding (bool)
import qualified PostgreSQL.Binary.Encoding as A
import qualified PostgreSQL.Binary.Data as B
import qualified Text.Builder as C
import qualified Hasql.Private.Encoders.Params as Params
import qualified Hasql.Private.Encoders.Value as Value
import qualified Hasql.Private.Encoders.Array as Array
import qualified Hasql.Private.PTI as PTI
import qualified Hasql.Private.Prelude as Prelude
-- * Parameters Product Encoder
-------------------------
-- |
-- Encoder of some representation of the 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 =
-- 'contramap' 'fst' ('param' 'int8') '<>'
-- 'contramap' 'snd' ('nullableParam' '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' 'int8') ('nullableParam' '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 =
-- 'contramap' name ('param' 'text') '<>'
-- 'contramap' gender ('param' genderValue) '<>'
-- 'contramap' (fromIntegral . age) ('param' 'int8')
--
-- genderValue :: 'Value' Gender
-- genderValue =
-- 'contramap' 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)
-- |
-- Encode no parameters.
--
{-# INLINABLE unit #-}
unit :: Params ()
unit =
Params mempty
-- |
-- Lift an individual value encoder to a parameters encoder.
--
{-# INLINABLE param #-}
param :: Value a -> Params a
param (Value x) =
Params (Params.value x)
-- |
-- Lift an individual nullable value encoder to a parameters encoder.
--
{-# INLINABLE nullableParam #-}
nullableParam :: Value a -> Params (Maybe a)
nullableParam (Value x) =
Params (Params.nullableValue x)
-- ** Instances
-------------------------
-- |
-- Maps to 'unit'.
instance Default (Params ()) where
{-# INLINE def #-}
def =
unit
instance Default (Value a) => Default (Params (Identity a)) where
{-# INLINE def #-}
def =
contramap runIdentity (param def)
instance (Default (Value a1), Default (Value a2)) => Default (Params (a1, a2)) where
{-# INLINE def #-}
def =
contrazip2 (param def) (param def)
instance (Default (Value a1), Default (Value a2), Default (Value a3)) => Default (Params (a1, a2, a3)) where
{-# INLINE def #-}
def =
contrazip3 (param def) (param def) (param def)
instance (Default (Value a1), Default (Value a2), Default (Value a3), Default (Value a4)) => Default (Params (a1, a2, a3, a4)) where
{-# INLINE def #-}
def =
contrazip4 (param def) (param def) (param def) (param def)
instance (Default (Value a1), Default (Value a2), Default (Value a3), Default (Value a4), Default (Value a5)) => Default (Params (a1, a2, a3, a4, a5)) where
{-# INLINE def #-}
def =
contrazip5 (param def) (param def) (param def) (param def) (param def)
-- * Value Encoder
-------------------------
-- |
-- An individual value encoder.
-- Will be mapped to a single placeholder in the query.
--
newtype Value a =
Value (Value.Value a)
deriving (Contravariant)
-- |
-- Encoder of @BOOL@ values.
{-# INLINABLE bool #-}
bool :: Value Bool
bool =
Value (Value.unsafePTIWithShow PTI.bool (const A.bool))
-- |
-- Encoder of @INT2@ values.
{-# INLINABLE int2 #-}
int2 :: Value Int16
int2 =
Value (Value.unsafePTIWithShow PTI.int2 (const A.int2_int16))
-- |
-- Encoder of @INT4@ values.
{-# INLINABLE int4 #-}
int4 :: Value Int32
int4 =
Value (Value.unsafePTIWithShow PTI.int4 (const A.int4_int32))
-- |
-- Encoder of @INT8@ values.
{-# INLINABLE int8 #-}
int8 :: Value Int64
int8 =
Value (Value.unsafePTIWithShow PTI.int8 (const A.int8_int64))
-- |
-- Encoder of @FLOAT4@ values.
{-# INLINABLE float4 #-}
float4 :: Value Float
float4 =
Value (Value.unsafePTIWithShow PTI.float4 (const A.float4))
-- |
-- Encoder of @FLOAT8@ values.
{-# INLINABLE float8 #-}
float8 :: Value Double
float8 =
Value (Value.unsafePTIWithShow PTI.float8 (const A.float8))
-- |
-- Encoder of @NUMERIC@ values.
{-# INLINABLE numeric #-}
numeric :: Value B.Scientific
numeric =
Value (Value.unsafePTIWithShow PTI.numeric (const A.numeric))
-- |
-- Encoder of @CHAR@ values.
-- Note that it supports UTF-8 values and
-- identifies itself under the @TEXT@ OID because of that.
{-# INLINABLE char #-}
char :: Value Char
char =
Value (Value.unsafePTIWithShow PTI.text (const A.char_utf8))
-- |
-- Encoder of @TEXT@ values.
{-# INLINABLE text #-}
text :: Value Text
text =
Value (Value.unsafePTIWithShow PTI.text (const A.text_strict))
-- |
-- Encoder of @BYTEA@ values.
{-# INLINABLE bytea #-}
bytea :: Value ByteString
bytea =
Value (Value.unsafePTIWithShow PTI.bytea (const A.bytea_strict))
-- |
-- Encoder of @DATE@ values.
{-# INLINABLE date #-}
date :: Value B.Day
date =
Value (Value.unsafePTIWithShow PTI.date (const A.date))
-- |
-- Encoder of @TIMESTAMP@ values.
{-# INLINABLE 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 #-}
timestamptz :: Value B.UTCTime
timestamptz =
Value (Value.unsafePTIWithShow PTI.timestamptz (Prelude.bool A.timestamptz_float A.timestamptz_int))
-- |
-- Encoder of @TIME@ values.
{-# INLINABLE time #-}
time :: Value B.TimeOfDay
time =
Value (Value.unsafePTIWithShow PTI.time (Prelude.bool A.time_float A.time_int))
-- |
-- Encoder of @TIMETZ@ values.
{-# INLINABLE timetz #-}
timetz :: Value (B.TimeOfDay, B.TimeZone)
timetz =
Value (Value.unsafePTIWithShow PTI.timetz (Prelude.bool A.timetz_float A.timetz_int))
-- |
-- Encoder of @INTERVAL@ values.
{-# INLINABLE 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 #-}
uuid :: Value B.UUID
uuid =
Value (Value.unsafePTIWithShow PTI.uuid (const A.uuid))
-- |
-- Encoder of @INET@ values.
{-# INLINABLE 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 #-}
json :: Value B.Value
json =
Value (Value.unsafePTIWithShow PTI.json (const A.json_ast))
-- |
-- Encoder of @JSON@ values from raw JSON.
{-# INLINABLE jsonBytes #-}
jsonBytes :: Value ByteString
jsonBytes =
Value (Value.unsafePTIWithShow PTI.json (const A.json_bytes))
-- |
-- Encoder of @JSONB@ values from JSON AST.
{-# INLINABLE jsonb #-}
jsonb :: Value B.Value
jsonb =
Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_ast))
-- |
-- Encoder of @JSONB@ values from raw JSON.
{-# INLINABLE jsonbBytes #-}
jsonbBytes :: Value ByteString
jsonbBytes =
Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_bytes))
-- |
-- Unlifts the 'Array' encoder to the plain 'Value' encoder.
{-# INLINABLE array #-}
array :: Array a -> Value a
array (Array (Array.Array valueOID arrayOID arrayEncoder renderer)) =
let
encoder env input =
A.array (PTI.oidWord32 valueOID) (arrayEncoder env input)
in Value (Value.Value arrayOID arrayOID encoder renderer)
-- |
-- Given a function,
-- which maps the value into the textual enum label from the DB side,
-- produces a encoder of that value.
{-# INLINABLE 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 #-}
unknown :: Value ByteString
unknown =
Value (Value.unsafePTIWithShow PTI.unknown (const A.bytea_strict))
-- ** Instances
-------------------------
-- | Maps to 'bool'.
instance Default (Value Bool) where
{-# INLINE def #-}
def =
bool
-- | Maps to 'int2'.
instance Default (Value Int16) where
{-# INLINE def #-}
def =
int2
-- | Maps to 'int4'.
instance Default (Value Int32) where
{-# INLINE def #-}
def =
int4
-- | Maps to 'int8'.
instance Default (Value Int64) where
{-# INLINE def #-}
def =
int8
-- | Maps to 'float4'.
instance Default (Value Float) where
{-# INLINE def #-}
def =
float4
-- | Maps to 'float8'.
instance Default (Value Double) where
{-# INLINE def #-}
def =
float8
-- | Maps to 'numeric'.
instance Default (Value B.Scientific) where
{-# INLINE def #-}
def =
numeric
-- | Maps to 'char'.
instance Default (Value Char) where
{-# INLINE def #-}
def =
char
-- | Maps to 'text'.
instance Default (Value Text) where
{-# INLINE def #-}
def =
text
-- | Maps to 'bytea'.
instance Default (Value ByteString) where
{-# INLINE def #-}
def =
bytea
-- | Maps to 'date'.
instance Default (Value B.Day) where
{-# INLINE def #-}
def =
date
-- | Maps to 'timestamp'.
instance Default (Value B.LocalTime) where
{-# INLINE def #-}
def =
timestamp
-- | Maps to 'timestamptz'.
instance Default (Value B.UTCTime) where
{-# INLINE def #-}
def =
timestamptz
-- | Maps to 'time'.
instance Default (Value B.TimeOfDay) where
{-# INLINE def #-}
def =
time
-- | Maps to 'timetz'.
instance Default (Value (B.TimeOfDay, B.TimeZone)) where
{-# INLINE def #-}
def =
timetz
-- | Maps to 'interval'.
instance Default (Value B.DiffTime) where
{-# INLINE def #-}
def =
interval
-- | Maps to 'uuid'.
instance Default (Value B.UUID) where
{-# INLINE def #-}
def =
uuid
-- | Maps to 'json'.
instance Default (Value B.Value) where
{-# INLINE def #-}
def =
json
-- * Array
-------------------------
-- |
-- A generic array encoder.
--
-- Here's an example of its usage:
--
-- >x :: Value [[Int64]]
-- >x =
-- > array (dimension foldl' (dimension foldl' (element 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 **field** = ANY($1) query instead.
--
newtype Array a =
Array (Array.Array a)
-- |
-- Lifts the 'Value' encoder into the 'Array' encoder of a non-nullable value.
{-# INLINABLE element #-}
element :: Value a -> Array a
element (Value (Value.Value elementOID arrayOID encoder renderer)) =
Array (Array.value elementOID arrayOID encoder renderer)
-- |
-- Lifts the 'Value' encoder into the 'Array' encoder of a nullable value.
{-# INLINABLE nullableElement #-}
nullableElement :: Value a -> Array (Maybe a)
nullableElement (Value (Value.Value elementOID arrayOID encoder renderer)) =
Array (Array.nullableValue elementOID arrayOID encoder renderer)
-- |
-- An 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',
-- 'element' or 'nullableElement'.
--
{-# INLINABLE dimension #-}
dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c
dimension foldl (Array imp) =
Array (Array.dimension foldl imp)
-- $insertMany
-- It is not currently possible to pass in an array of encodable values
-- to use in an 'insert many' statement using Hasql. Instead, PostgreSQL's
-- (9.4 or later) `unnest` function can be used to 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.unzip3 $
-- contrazip3 (vector Encoders.uuid) (vector Encoders.float8) (vector Encoders.float8)
-- where
-- vector value =
-- Encoders.param (Encoders.array (Encoders.dimension foldl' (Encoders.element value)))
-- decoder =
-- Decoders.unit
-- @
import Hasql.Private.Encoders

459
library/Hasql/Private/Decoders.hs Normal file
View File

@ -0,0 +1,459 @@
{-|
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 Hasql.Private.Decoders.Array as Array
import qualified Hasql.Private.Decoders.Composite as Composite
import qualified Hasql.Private.Prelude as Prelude
import qualified Data.Vector.Generic as GenericVector
-- * 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 #-}
noResult :: Result ()
noResult = Result (Results.single Result.noResult)
{-|
Get the amount of rows affected by such statements as
@UPDATE@ or @DELETE@.
-}
{-# INLINABLE rowsAffected #-}
rowsAffected :: Result Int64
rowsAffected = Result (Results.single Result.rowsAffected)
{-|
Exactly one row.
Will raise the 'Hasql.Errors.UnexpectedAmountOfRows' error if it's any other.
-}
{-# INLINABLE singleRow #-}
singleRow :: Row a -> Result a
singleRow (Row row) = Result (Results.single (Result.single row))
-- ** Multi-row traversers
-------------------------
{-|
Foldl multiple rows.
-}
{-# INLINABLE 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 #-}
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 #-}
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 #-}
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 #-}
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'
@
-}
newtype Row a = Row (Row.Row a)
deriving (Functor, Applicative, Monad)
{-|
Lift an individual non-nullable value decoder to a composable row decoder.
-}
{-# INLINABLE column #-}
column :: NullableOrNot Value a -> Row a
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.
-}
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.
-}
nonNullable :: decoder a -> NullableOrNot decoder a
nonNullable = NonNullable
{-|
Specify that a decoder produces a nullable value.
-}
nullable :: decoder a -> NullableOrNot decoder (Maybe a)
nullable = Nullable
-- * Value
-------------------------
{-|
Decoder of a value.
-}
newtype Value a = Value (Value.Value a)
deriving (Functor)
{-|
Decoder of the @BOOL@ values.
-}
{-# INLINABLE bool #-}
bool :: Value Bool
bool = Value (Value.decoder (const A.bool))
{-|
Decoder of the @INT2@ values.
-}
{-# INLINABLE int2 #-}
int2 :: Value Int16
int2 = Value (Value.decoder (const A.int))
{-|
Decoder of the @INT4@ values.
-}
{-# INLINABLE int4 #-}
int4 :: Value Int32
int4 = Value (Value.decoder (const A.int))
{-|
Decoder of the @INT8@ values.
-}
{-# INLINABLE int8 #-}
int8 :: Value Int64
int8 = {-# SCC "int8" #-}
Value (Value.decoder (const ({-# SCC "int8.int" #-} A.int)))
{-|
Decoder of the @FLOAT4@ values.
-}
{-# INLINABLE float4 #-}
float4 :: Value Float
float4 = Value (Value.decoder (const A.float4))
{-|
Decoder of the @FLOAT8@ values.
-}
{-# INLINABLE float8 #-}
float8 :: Value Double
float8 = Value (Value.decoder (const A.float8))
{-|
Decoder of the @NUMERIC@ values.
-}
{-# INLINABLE 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 #-}
char :: Value Char
char = Value (Value.decoder (const A.char))
{-|
Decoder of the @TEXT@ values.
-}
{-# INLINABLE text #-}
text :: Value Text
text = Value (Value.decoder (const A.text_strict))
{-|
Decoder of the @BYTEA@ values.
-}
{-# INLINABLE bytea #-}
bytea :: Value ByteString
bytea = Value (Value.decoder (const A.bytea_strict))
{-|
Decoder of the @DATE@ values.
-}
{-# INLINABLE date #-}
date :: Value B.Day
date = Value (Value.decoder (const A.date))
{-|
Decoder of the @TIMESTAMP@ values.
-}
{-# INLINABLE 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 #-}
timestamptz :: Value B.UTCTime
timestamptz = Value (Value.decoder (Prelude.bool A.timestamptz_float A.timestamptz_int))
{-|
Decoder of the @TIME@ values.
-}
{-# INLINABLE 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 #-}
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 #-}
interval :: Value B.DiffTime
interval = Value (Value.decoder (Prelude.bool A.interval_float A.interval_int))
{-|
Decoder of the @UUID@ values.
-}
{-# INLINABLE uuid #-}
uuid :: Value B.UUID
uuid = Value (Value.decoder (const A.uuid))
{-|
Decoder of the @INET@ values.
-}
{-# INLINABLE 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 #-}
json :: Value B.Value
json = Value (Value.decoder (const A.json_ast))
{-|
Decoder of the @JSON@ values into a raw JSON 'ByteString'.
-}
{-# INLINABLE 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 #-}
jsonb :: Value B.Value
jsonb = Value (Value.decoder (const A.jsonb_ast))
{-|
Decoder of the @JSONB@ values into a raw JSON 'ByteString'.
-}
{-# INLINABLE 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 #-}
custom :: (Bool -> ByteString -> Either Text a) -> Value a
custom fn = Value (Value.decoderFn fn)
{-|
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 #-}
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.
-}
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 #-}
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'.
-}
{-# 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'.
-}
{-# 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 #-}
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'))))
@
-}
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 #-}
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 #-}
element :: NullableOrNot Value a -> Array a
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).
-}
newtype Composite a = Composite (Composite.Composite a)
deriving (Functor, Applicative, Monad)
{-|
Lift a 'Value' decoder into a 'Composite' decoder for parsing of component values.
-}
field :: NullableOrNot Value a -> Composite a
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/Result.hs
View File

@ -20,9 +20,9 @@ run :: Result a -> (Bool, LibPQ.Result) -> IO (Either ResultError a)
run (Result reader) env =
runExceptT (runReaderT reader env)
{-# INLINE unit #-}
unit :: Result ()
unit =
{-# INLINE noResult #-}
noResult :: Result ()
noResult =
checkExecStatus $ \case
LibPQ.CommandOk -> True
LibPQ.TuplesOk -> True

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

@ -81,4 +81,4 @@ dropRemainders =
loop integerDatetimes connection <* checkErrors
where
checkErrors =
ExceptT $ fmap (mapLeft ResultError) $ Result.run Result.unit (integerDatetimes, result)
ExceptT $ fmap (mapLeft ResultError) $ Result.run Result.noResult (integerDatetimes, result)

371
library/Hasql/Private/Encoders.hs Normal file
View File

@ -0,0 +1,371 @@
{-|
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.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 qualified Hasql.Private.Prelude as Prelude
-- * 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"
@
-}
newtype Params a = Params (Params.Params a)
deriving (Contravariant, Divisible, Decidable, Monoid, Semigroup)
{-|
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.
-}
param :: NullableOrNot Value a -> Params a
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.
-}
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.
-}
nonNullable :: encoder a -> NullableOrNot encoder a
nonNullable = NonNullable
{-|
Specify that an encoder produces a nullable value.
-}
nullable :: encoder a -> NullableOrNot encoder (Maybe a)
nullable = Nullable
-- * Value
-------------------------
{-|
Value encoder.
-}
newtype Value a = Value (Value.Value a)
deriving (Contravariant)
{-|
Encoder of @BOOL@ values.
-}
{-# INLINABLE bool #-}
bool :: Value Bool
bool = Value (Value.unsafePTIWithShow PTI.bool (const A.bool))
{-|
Encoder of @INT2@ values.
-}
{-# INLINABLE int2 #-}
int2 :: Value Int16
int2 = Value (Value.unsafePTIWithShow PTI.int2 (const A.int2_int16))
{-|
Encoder of @INT4@ values.
-}
{-# INLINABLE int4 #-}
int4 :: Value Int32
int4 = Value (Value.unsafePTIWithShow PTI.int4 (const A.int4_int32))
{-|
Encoder of @INT8@ values.
-}
{-# INLINABLE int8 #-}
int8 :: Value Int64
int8 = Value (Value.unsafePTIWithShow PTI.int8 (const A.int8_int64))
{-|
Encoder of @FLOAT4@ values.
-}
{-# INLINABLE float4 #-}
float4 :: Value Float
float4 = Value (Value.unsafePTIWithShow PTI.float4 (const A.float4))
{-|
Encoder of @FLOAT8@ values.
-}
{-# INLINABLE float8 #-}
float8 :: Value Double
float8 = Value (Value.unsafePTIWithShow PTI.float8 (const A.float8))
{-|
Encoder of @NUMERIC@ values.
-}
{-# INLINABLE 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 #-}
char :: Value Char
char = Value (Value.unsafePTIWithShow PTI.text (const A.char_utf8))
{-|
Encoder of @TEXT@ values.
-}
{-# INLINABLE text #-}
text :: Value Text
text = Value (Value.unsafePTIWithShow PTI.text (const A.text_strict))
{-|
Encoder of @BYTEA@ values.
-}
{-# INLINABLE bytea #-}
bytea :: Value ByteString
bytea = Value (Value.unsafePTIWithShow PTI.bytea (const A.bytea_strict))
{-|
Encoder of @DATE@ values.
-}
{-# INLINABLE date #-}
date :: Value B.Day
date = Value (Value.unsafePTIWithShow PTI.date (const A.date))
{-|
Encoder of @TIMESTAMP@ values.
-}
{-# INLINABLE 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 #-}
timestamptz :: Value B.UTCTime
timestamptz = Value (Value.unsafePTIWithShow PTI.timestamptz (Prelude.bool A.timestamptz_float A.timestamptz_int))
{-|
Encoder of @TIME@ values.
-}
{-# INLINABLE time #-}
time :: Value B.TimeOfDay
time = Value (Value.unsafePTIWithShow PTI.time (Prelude.bool A.time_float A.time_int))
{-|
Encoder of @TIMETZ@ values.
-}
{-# INLINABLE timetz #-}
timetz :: Value (B.TimeOfDay, B.TimeZone)
timetz = Value (Value.unsafePTIWithShow PTI.timetz (Prelude.bool A.timetz_float A.timetz_int))
{-|
Encoder of @INTERVAL@ values.
-}
{-# INLINABLE 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 #-}
uuid :: Value B.UUID
uuid = Value (Value.unsafePTIWithShow PTI.uuid (const A.uuid))
{-|
Encoder of @INET@ values.
-}
{-# INLINABLE 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 #-}
json :: Value B.Value
json = Value (Value.unsafePTIWithShow PTI.json (const A.json_ast))
{-|
Encoder of @JSON@ values from raw JSON.
-}
{-# INLINABLE jsonBytes #-}
jsonBytes :: Value ByteString
jsonBytes = Value (Value.unsafePTIWithShow PTI.json (const A.json_bytes))
{-|
Encoder of @JSONB@ values from JSON AST.
-}
{-# INLINABLE jsonb #-}
jsonb :: Value B.Value
jsonb = Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_ast))
{-|
Encoder of @JSONB@ values from raw JSON.
-}
{-# INLINABLE 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 #-}
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 #-}
unknown :: Value ByteString
unknown = Value (Value.unsafePTIWithShow PTI.unknown (const A.bytea_strict))
{-|
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)
{-|
Lift a value encoder of element into a unidimensional array encoder of a foldable value.
E.g.,
@
vectorOfInts :: Value (Vector Int64)
vectorOfInts = 'foldableArray' ('nonNullable' 'int8')
@
This function is merely a shortcut to the following expression:
@
('array' . 'dimension' 'foldl'' . 'element')
@
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.
-}
newtype Array a = Array (Array.Array a)
deriving (Contravariant)
{-|
Lifts a 'Value' encoder into an 'Array' encoder.
-}
element :: NullableOrNot Value a -> Array a
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 #-}
dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c
dimension foldl (Array imp) = Array (Array.dimension foldl imp)

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

@ -9,6 +9,10 @@ import qualified Text.Builder as C
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)
{-# INLINE value #-}
value :: B.OID -> B.OID -> (Bool -> a -> A.Encoding) -> (a -> C.Builder) -> Array a
value valueOID arrayOID encoder =

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

@ -88,7 +88,7 @@ getPreparedStatementKey connection registry template oidList =
sent <- LibPQ.sendPrepare connection key template (mfilter (not . null) (Just oidList))
let resultsDecoder =
if sent
then ResultsDecoders.single ResultDecoders.unit
then ResultsDecoders.single ResultDecoders.noResult
else ResultsDecoders.clientError
fmap resultsMapping $ getResults connection undefined resultsDecoder
where

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

@ -36,10 +36,6 @@ import Data.Functor.Identity as Exports
-------------------------
import Control.Monad.Error.Class as Exports (MonadError (..))
-- data-default-class
-------------------------
import Data.Default.Class as Exports
-- profunctors
-------------------------
import Data.Profunctor.Unsafe as Exports
@ -85,6 +81,10 @@ import Development.Placeholders as Exports
-------------------------
import Debug.Trace.LocationTH as Exports
-- postgresql-binary
-------------------------
import PostgreSQL.Binary.Data as Exports (UUID)
-- custom
-------------------------
import qualified Debug.Trace.LocationTH

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

@ -7,6 +7,7 @@ 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
@ -39,21 +40,21 @@ sql sql =
return $ r1 *> r2
where
decoder =
Decoders.Results.single Decoders.Result.unit
Decoders.Results.single Decoders.Result.noResult
-- |
-- 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 encoder decoder preparable) =
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 (unsafeCoerce encoder) preparable input
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) = (unsafeCoerce encoder)
Encoders.Params.Params (Op encoderOp) = paramsEncoder
step (_, _, _, rendering) acc =
rendering : acc
in foldr step [] (encoderOp input)

128
library/Hasql/Statement.hs
View File

@ -1,47 +1,53 @@
module Hasql.Statement
(
Statement(..),
-- * Recipies
-- ** 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
{-|
Specification of a strictly single-statement query, which can be parameterized and prepared.
-- |
-- A 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 the positional notation, as in the following:
-- @$1@, @$2@, @$3@ and etc.
-- Those references must be used to refer to the values of the 'Encoders.Params' encoder.
--
-- Following is an example of the declaration of a prepared statement with its associated codecs.
--
-- @
-- selectSum :: Hasql.Statement.'Statement' (Int64, Int64) Int64
-- selectSum =
-- Hasql.Statement.'Statement' sql encoder decoder True
-- where
-- sql =
-- "select ($1 + $2)"
-- encoder =
-- 'contramap' 'fst' (Hasql.Encoders.'Hasql.Encoders.param' Hasql.Encoders.'Hasql.Encoders.int8') '<>'
-- 'contramap' 'snd' (Hasql.Encoders.'Hasql.Encoders.param' Hasql.Encoders.'Hasql.Encoders.int8')
-- decoder =
-- Hasql.Decoders.'Hasql.Decoders.singleRow' (Hasql.Decoders.'Hasql.Decoders.column' Hasql.Decoders.'Hasql.Decoders.int8')
-- @
--
-- The statement above accepts a product of two parameters of type 'Int64'
-- and produces a single result of type 'Int64'.
--
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 to the order in which the according
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.nullable' Encoders.'Hasql.Encoders.text'))
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
@ -53,3 +59,53 @@ instance Profunctor Statement where
{-# INLINE dimap #-}
dimap f1 f2 (Statement template encoder decoder preparable) =
Statement template (contramap f1 encoder) (fmap f2 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.
-}
{- $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>.
-}

4
profiling/Main.hs
View File

@ -70,7 +70,7 @@ statementWithSingleRow =
D.singleRow row
where
row =
tuple <$> D.column D.int8 <*> D.column D.int8
tuple <$> (D.column . D.nonNullable) D.int8 <*> (D.column . D.nonNullable) D.int8
where
tuple !a !b =
(a, b)
@ -84,7 +84,7 @@ statementWithManyRows decoder =
encoder =
conquer
rowDecoder =
tuple <$> D.column D.int8 <*> D.column D.int8
tuple <$> (D.column . D.nonNullable) D.int8 <*> (D.column . D.nonNullable) D.int8
where
tuple !a !b =
(a, b)

120
tasty/Main.hs
View File

@ -22,6 +22,26 @@ 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 =
@ -29,10 +49,10 @@ tree =
where
encoder =
contrazip2
(Encoders.param (Encoders.array (Encoders.dimension foldl' (Encoders.element Encoders.int8))))
(Encoders.param Encoders.text)
(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.bool))
fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool))
session =
Session.statement ([3, 7], "a") statement
in do
@ -47,9 +67,9 @@ tree =
Statement.Statement "select true where 1 = any ($1)" encoder decoder True
where
encoder =
Encoders.param (Encoders.array (Encoders.dimension foldl' (Encoders.element Encoders.int8)))
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.bool))
fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool))
session =
do
result1 <- Session.statement [1, 2] statement
@ -65,9 +85,9 @@ tree =
Statement.Statement "select true where 3 <> all ($1)" encoder decoder True
where
encoder =
Encoders.param (Encoders.array (Encoders.dimension foldl' (Encoders.element Encoders.int8)))
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.bool))
fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool))
session =
do
result1 <- Session.statement [1, 2] statement
@ -85,9 +105,9 @@ tree =
sql =
"select (1, true)"
encoder =
Encoders.unit
mempty
decoder =
Decoders.singleRow (Decoders.column (Decoders.composite ((,) <$> Decoders.field Decoders.int8 <*> Decoders.field Decoders.bool)))
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
@ -102,17 +122,17 @@ tree =
sql =
"select (1, true) as entity1, ('hello', 3) as entity2"
encoder =
Encoders.unit
mempty
decoder =
Decoders.singleRow $
(,) <$> Decoders.column entity1 <*> Decoders.column entity2
(,) <$> (Decoders.column . Decoders.nonNullable) entity1 <*> (Decoders.column . Decoders.nonNullable) entity2
where
entity1 =
Decoders.composite $
(,) <$> Decoders.field Decoders.int8 <*> Decoders.field Decoders.bool
(,) <$> (Decoders.field . Decoders.nonNullable) Decoders.int8 <*> (Decoders.field . Decoders.nonNullable) Decoders.bool
entity2 =
Decoders.composite $
(,) <$> Decoders.field Decoders.text <*> Decoders.field Decoders.int8
(,) <$> (Decoders.field . Decoders.nonNullable) Decoders.text <*> (Decoders.field . Decoders.nonNullable) Decoders.int8
session =
Session.statement () statement
in do
@ -135,9 +155,9 @@ tree =
sql =
"select array[]::int8[]"
encoder =
Encoders.unit
mempty
decoder =
Decoders.singleRow (Decoders.column (Decoders.array (Decoders.dimension replicateM (Decoders.element Decoders.int8))))
Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.array (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8)))))
in io
,
testCase "Failing prepared statements" $
@ -162,9 +182,9 @@ tree =
sql =
"absurd"
encoder =
Encoders.unit
mempty
decoder =
Decoders.unit
Decoders.noResult
in io
,
testCase "Prepared statements after error" $
@ -185,9 +205,9 @@ tree =
sql =
"select $1 :: int8"
encoder =
Encoders.param Encoders.int8
Encoders.param (Encoders.nonNullable (Encoders.int8))
decoder =
Decoders.singleRow $ Decoders.column Decoders.int8
Decoders.singleRow $ (Decoders.column . Decoders.nonNullable) Decoders.int8
fail =
catchError (Session.sql "absurd") (const (pure ()))
in io
@ -201,10 +221,10 @@ tree =
sql =
"select ($1 + $2)"
encoder =
contramap fst (Encoders.param Encoders.int8) <>
contramap snd (Encoders.param Encoders.int8)
contramap fst (Encoders.param (Encoders.nonNullable (Encoders.int8))) <>
contramap snd (Encoders.param (Encoders.nonNullable (Encoders.int8)))
decoder =
Decoders.singleRow (Decoders.column Decoders.int8)
Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8)
sumSession :: Session.Session Int64
sumSession =
Session.sql "begin" *> Session.statement (1, 1) sumStatement <* Session.sql "end"
@ -226,10 +246,10 @@ tree =
sql =
"select ($1 + $2)"
encoder =
contramap fst (Encoders.param Encoders.int8) <>
contramap snd (Encoders.param Encoders.int8)
contramap fst (Encoders.param (Encoders.nonNullable (Encoders.int8))) <>
contramap snd (Encoders.param (Encoders.nonNullable (Encoders.int8)))
decoder =
Decoders.singleRow (Decoders.column Decoders.int8)
Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8)
session :: Session.Session Int64
session =
do
@ -253,9 +273,9 @@ tree =
sql =
"select $1 = interval '10 seconds'"
decoder =
(Decoders.singleRow (Decoders.column (Decoders.bool)))
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool)))
encoder =
Encoders.param (Encoders.interval)
Encoders.param (Encoders.nonNullable (Encoders.interval))
in DSL.statement (10 :: DiffTime) statement
in actualIO >>= \x -> assertEqual (show x) (Right True) x
,
@ -270,9 +290,9 @@ tree =
sql =
"select interval '10 seconds'"
decoder =
(Decoders.singleRow (Decoders.column (Decoders.interval)))
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval)))
encoder =
Encoders.unit
Encoders.noParams
in DSL.statement () statement
in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x
,
@ -287,9 +307,9 @@ tree =
sql =
"select $1"
decoder =
(Decoders.singleRow (Decoders.column (Decoders.interval)))
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval)))
encoder =
Encoders.param (Encoders.interval)
Encoders.param (Encoders.nonNullable (Encoders.interval))
in DSL.statement (10 :: DiffTime) statement
in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x
,
@ -299,14 +319,14 @@ tree =
DSL.session $ do
let
statement =
Statement.Statement sql mempty Decoders.unit True
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.unit True
Statement.Statement sql mempty Decoders.noResult True
where
sql =
"create type mood as enum ('sad', 'ok', 'happy')"
@ -318,9 +338,9 @@ tree =
sql =
"select $1 = ('ok' :: mood)"
decoder =
(Decoders.singleRow (Decoders.column (Decoders.bool)))
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool)))
encoder =
Encoders.param (Encoders.unknown)
Encoders.param (Encoders.nonNullable (Encoders.unknown))
in DSL.statement "ok" statement
in actualIO >>= assertEqual "" (Right True)
,
@ -330,14 +350,14 @@ tree =
DSL.session $ do
let
statement =
Statement.Statement sql mempty Decoders.unit True
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.unit True
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;"
@ -349,9 +369,9 @@ tree =
sql =
"select overloaded($1, $2) || overloaded($3, $4, $5)"
decoder =
(Decoders.singleRow (Decoders.column (Decoders.text)))
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text)))
encoder =
contramany (Encoders.param Encoders.unknown)
contramany (Encoders.param (Encoders.nonNullable (Encoders.unknown)))
in DSL.statement ["1", "2", "4", "5", "6"] statement
in actualIO >>= assertEqual "" (Right "3456")
,
@ -361,14 +381,14 @@ tree =
DSL.session $ do
let
statement =
Statement.Statement sql mempty Decoders.unit True
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.unit True
Statement.Statement sql mempty Decoders.noResult True
where
sql =
"create type mood as enum ('sad', 'ok', 'happy')"
@ -380,9 +400,9 @@ tree =
sql =
"select ($1 :: mood)"
decoder =
(Decoders.singleRow (Decoders.column (Decoders.enum (Just . id))))
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.enum (Just . id))))
encoder =
Encoders.param (Encoders.enum id)
Encoders.param (Encoders.nonNullable ((Encoders.enum id)))
in DSL.statement "ok" statement
in actualIO >>= assertEqual "" (Right "ok")
,
@ -400,9 +420,9 @@ tree =
sql =
"select $1"
encoder =
Encoders.param Encoders.text
Encoders.param (Encoders.nonNullable (Encoders.text))
decoder =
(Decoders.singleRow (Decoders.column (Decoders.text)))
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text)))
effect2 =
DSL.statement 1 statement
where
@ -412,9 +432,9 @@ tree =
sql =
"select $1"
encoder =
Encoders.param Encoders.int8
Encoders.param (Encoders.nonNullable (Encoders.int8))
decoder =
(Decoders.singleRow (Decoders.column Decoders.int8))
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8))
in (,) <$> effect1 <*> effect2
in actualIO >>= assertEqual "" (Right ("ok", 1))
,
@ -438,7 +458,7 @@ tree =
DSL.statement () $ Statements.plain $
"insert into a (name) values ('a')"
deleteRows =
DSL.statement () $ Statement.Statement sql def decoder False
DSL.statement () $ Statement.Statement sql mempty decoder False
where
sql =
"delete from a"
@ -452,8 +472,8 @@ tree =
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" def (Decoders.singleRow (Decoders.column Decoders.int4)) False
id2 <- DSL.statement () $ Statement.Statement "insert into a (v) values ('b') returning id" def (Decoders.singleRow (Decoders.column Decoders.int4)) False
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

4
tasty/Main/Prelude.hs
View File

@ -8,7 +8,3 @@ where
-- rerebase
-------------------------
import Prelude as Exports
-- data-default-class
-------------------------
import Data.Default.Class as Exports

10
tasty/Main/Statements.hs
View File

@ -1,19 +1,15 @@
module Main.Statements where
import Main.Prelude hiding (def)
import Main.Prelude
import qualified Hasql.Statement as HQ
import qualified Hasql.Encoders as HE
import qualified Hasql.Decoders as HD
import qualified Main.Prelude as Prelude
def :: ByteString -> HQ.Statement () ()
def sql =
HQ.Statement sql Prelude.def Prelude.def False
plain :: ByteString -> HQ.Statement () ()
plain sql =
HQ.Statement sql mempty HD.unit False
HQ.Statement sql mempty HD.noResult False
dropType :: ByteString -> HQ.Statement () ()
dropType name =
@ -33,4 +29,4 @@ selectList =
sql =
"values (1,2), (3,4), (5,6)"
decoder =
HD.rowList ((,) <$> HD.column HD.int8 <*> HD.column HD.int8)
HD.rowList ((,) <$> (HD.column . HD.nonNullable) HD.int8 <*> (HD.column . HD.nonNullable) HD.int8)

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

@ -13,8 +13,8 @@ selectSleep =
sql =
"select pg_sleep($1)"
encoder =
E.param E.float8
E.param (E.nonNullable E.float8)
decoder =
D.unit
D.noResult