packages feed

hasql 1.6.4 → 1.6.4.1

raw patch · 47 files changed

+2370/−2519 lines, 47 filesdep +criteriondep −gaugePVP ok

version bump matches the API change (PVP)

Dependencies added: criterion

Dependencies removed: gauge

API changes (from Hackage documentation)

Files

benchmarks/Main.hs view
@@ -1,15 +1,14 @@ module Main where -import qualified Data.Vector as F-import Gauge-import Gauge.Main+import Criterion+import Criterion.Main import qualified Hasql.Connection as A import qualified Hasql.Decoders as D-import qualified Hasql.Encoders as E import qualified Hasql.Session as B import qualified Hasql.Statement as C import Prelude +main :: IO () main =   do     Right connection <- acquireConnection
hasql.cabal view
@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               hasql-version:            1.6.4+version:            1.6.4.1 category:           Hasql, Database, PostgreSQL synopsis:           An efficient PostgreSQL driver with a flexible mapping API description:@@ -24,8 +24,7 @@   type:     git   location: git://github.com/nikita-volkov/hasql.git -library-  hs-source-dirs:     library+common base   default-extensions:     NoImplicitPrelude     NoMonomorphismRestriction@@ -66,6 +65,19 @@     UnboxedTuples    default-language:   Haskell2010++common executable+  import:      base+  ghc-options:+    -O2 -threaded -with-rtsopts=-N -rtsopts -funbox-strict-fields++common test+  import:      base+  ghc-options: -threaded -with-rtsopts=-N++library+  import:          base+  hs-source-dirs:  library   exposed-modules:     Hasql.Connection     Hasql.Decoders@@ -74,26 +86,26 @@     Hasql.Statement    other-modules:-    Hasql.Private.Commands-    Hasql.Private.Connection-    Hasql.Private.Decoders-    Hasql.Private.Decoders.Array-    Hasql.Private.Decoders.Composite-    Hasql.Private.Decoders.Result-    Hasql.Private.Decoders.Results-    Hasql.Private.Decoders.Row-    Hasql.Private.Decoders.Value-    Hasql.Private.Encoders-    Hasql.Private.Encoders.Array-    Hasql.Private.Encoders.Params-    Hasql.Private.Encoders.Value-    Hasql.Private.Errors-    Hasql.Private.IO-    Hasql.Private.Prelude-    Hasql.Private.PreparedStatementRegistry-    Hasql.Private.PTI-    Hasql.Private.Session-    Hasql.Private.Settings+    Hasql.Commands+    Hasql.Connection.Core+    Hasql.Decoders.All+    Hasql.Decoders.Array+    Hasql.Decoders.Composite+    Hasql.Decoders.Result+    Hasql.Decoders.Results+    Hasql.Decoders.Row+    Hasql.Decoders.Value+    Hasql.Encoders.All+    Hasql.Encoders.Array+    Hasql.Encoders.Params+    Hasql.Encoders.Value+    Hasql.Errors+    Hasql.IO+    Hasql.Prelude+    Hasql.PreparedStatementRegistry+    Hasql.PTI+    Hasql.Session.Core+    Hasql.Settings    build-depends:     , aeson >=2 && <3@@ -119,49 +131,10 @@     , vector >=0.10 && <0.14  test-suite tasty-  type:               exitcode-stdio-1.0-  hs-source-dirs:     tasty-  main-is:            Main.hs-  default-extensions:-    NoImplicitPrelude-    NoMonomorphismRestriction-    Arrows-    BangPatterns-    ConstraintKinds-    DataKinds-    DefaultSignatures-    DeriveDataTypeable-    DeriveFoldable-    DeriveFunctor-    DeriveGeneric-    DeriveTraversable-    EmptyDataDecls-    FlexibleContexts-    FlexibleInstances-    FunctionalDependencies-    GADTs-    GeneralizedNewtypeDeriving-    LambdaCase-    LiberalTypeSynonyms-    MagicHash-    MultiParamTypeClasses-    MultiWayIf-    OverloadedStrings-    ParallelListComp-    PatternGuards-    QuasiQuotes-    RankNTypes-    RecordWildCards-    RoleAnnotations-    ScopedTypeVariables-    StandaloneDeriving-    TemplateHaskell-    TupleSections-    TypeFamilies-    TypeOperators-    UnboxedTuples--  default-language:   Haskell2010+  import:         base+  type:           exitcode-stdio-1.0+  hs-source-dirs: tasty+  main-is:        Main.hs   other-modules:     Main.Connection     Main.DSL@@ -178,152 +151,31 @@     , tasty-quickcheck >=0.9 && <0.11  test-suite threads-test-  type:               exitcode-stdio-1.0-  hs-source-dirs:     threads-test-  main-is:            Main.hs-  default-extensions:-    NoImplicitPrelude-    NoMonomorphismRestriction-    Arrows-    BangPatterns-    ConstraintKinds-    DataKinds-    DefaultSignatures-    DeriveDataTypeable-    DeriveFoldable-    DeriveFunctor-    DeriveGeneric-    DeriveTraversable-    EmptyDataDecls-    FlexibleContexts-    FlexibleInstances-    FunctionalDependencies-    GADTs-    GeneralizedNewtypeDeriving-    LambdaCase-    LiberalTypeSynonyms-    MagicHash-    MultiParamTypeClasses-    MultiWayIf-    OverloadedStrings-    ParallelListComp-    PatternGuards-    QuasiQuotes-    RankNTypes-    RecordWildCards-    RoleAnnotations-    ScopedTypeVariables-    StandaloneDeriving-    TemplateHaskell-    TupleSections-    TypeFamilies-    TypeOperators-    UnboxedTuples--  default-language:   Haskell2010-  other-modules:      Main.Statements-  ghc-options:        -O2 -threaded -with-rtsopts=-N+  import:         test+  type:           exitcode-stdio-1.0+  hs-source-dirs: threads-test+  main-is:        Main.hs+  other-modules:  Main.Statements   build-depends:     , hasql     , rerebase  benchmark benchmarks-  type:               exitcode-stdio-1.0-  hs-source-dirs:     benchmarks-  main-is:            Main.hs-  default-extensions:-    NoImplicitPrelude-    NoMonomorphismRestriction-    Arrows-    BangPatterns-    ConstraintKinds-    DataKinds-    DefaultSignatures-    DeriveDataTypeable-    DeriveFoldable-    DeriveFunctor-    DeriveGeneric-    DeriveTraversable-    EmptyDataDecls-    FlexibleContexts-    FlexibleInstances-    FunctionalDependencies-    GADTs-    GeneralizedNewtypeDeriving-    LambdaCase-    LiberalTypeSynonyms-    MagicHash-    MultiParamTypeClasses-    MultiWayIf-    OverloadedStrings-    ParallelListComp-    PatternGuards-    QuasiQuotes-    RankNTypes-    RecordWildCards-    RoleAnnotations-    ScopedTypeVariables-    StandaloneDeriving-    TemplateHaskell-    TupleSections-    TypeFamilies-    TypeOperators-    UnboxedTuples--  default-language:   Haskell2010-  ghc-options:-    -O2 -threaded -with-rtsopts=-N -rtsopts -funbox-strict-fields-+  import:         executable+  type:           exitcode-stdio-1.0+  hs-source-dirs: benchmarks+  main-is:        Main.hs   build-depends:-    , gauge >=0.2.5 && <0.3+    , criterion >=1.6 && <2     , hasql     , rerebase <2  test-suite profiling-  type:               exitcode-stdio-1.0-  hs-source-dirs:     profiling-  main-is:            Main.hs-  default-extensions:-    NoImplicitPrelude-    NoMonomorphismRestriction-    Arrows-    BangPatterns-    ConstraintKinds-    DataKinds-    DefaultSignatures-    DeriveDataTypeable-    DeriveFoldable-    DeriveFunctor-    DeriveGeneric-    DeriveTraversable-    EmptyDataDecls-    FlexibleContexts-    FlexibleInstances-    FunctionalDependencies-    GADTs-    GeneralizedNewtypeDeriving-    LambdaCase-    LiberalTypeSynonyms-    MagicHash-    MultiParamTypeClasses-    MultiWayIf-    OverloadedStrings-    ParallelListComp-    PatternGuards-    QuasiQuotes-    RankNTypes-    RecordWildCards-    RoleAnnotations-    ScopedTypeVariables-    StandaloneDeriving-    TemplateHaskell-    TupleSections-    TypeFamilies-    TypeOperators-    UnboxedTuples--  default-language:   Haskell2010-  ghc-options:        -O2 -threaded -rtsopts+  import:         base+  type:           exitcode-stdio-1.0+  hs-source-dirs: profiling+  main-is:        Main.hs+  ghc-options:    -O2 -threaded -rtsopts   build-depends:     , hasql     , rerebase >=1 && <2
+ library/Hasql/Commands.hs view
@@ -0,0 +1,27 @@+module Hasql.Commands+  ( Commands,+    asBytes,+    setEncodersToUTF8,+    setMinClientMessagesToWarning,+  )+where++import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL+import Hasql.Prelude++newtype Commands+  = Commands (DList BB.Builder)+  deriving (Semigroup, Monoid)++asBytes :: Commands -> ByteString+asBytes (Commands list) =+  BL.toStrict $ BB.toLazyByteString $ foldMap (<> BB.char7 ';') $ list++setEncodersToUTF8 :: Commands+setEncodersToUTF8 =+  Commands (pure "SET client_encoding = 'UTF8'")++setMinClientMessagesToWarning :: Commands+setMinClientMessagesToWarning =+  Commands (pure "SET client_min_messages TO WARNING")
library/Hasql/Connection.hs view
@@ -11,5 +11,5 @@   ) where -import Hasql.Private.Connection-import Hasql.Private.Settings+import Hasql.Connection.Core+import Hasql.Settings
+ library/Hasql/Connection/Core.hs view
@@ -0,0 +1,50 @@+-- |+-- This module provides a low-level effectful API dealing with the connections to the database.+module Hasql.Connection.Core where++import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Hasql.IO as IO+import Hasql.Prelude+import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry+import qualified Hasql.Settings as Settings++-- |+-- A single connection to the database.+data Connection+  = Connection !(MVar LibPQ.Connection) !Bool !PreparedStatementRegistry.PreparedStatementRegistry++-- |+-- Possible details of the connection acquistion error.+type ConnectionError =+  Maybe ByteString++-- |+-- Acquire a connection using the provided settings encoded according to the PostgreSQL format.+acquire :: Settings.Settings -> IO (Either ConnectionError Connection)+acquire settings =+  {-# SCC "acquire" #-}+  runExceptT $ do+    pqConnection <- lift (IO.acquireConnection settings)+    lift (IO.checkConnectionStatus pqConnection) >>= traverse throwError+    lift (IO.initConnection pqConnection)+    integerDatetimes <- lift (IO.getIntegerDatetimes pqConnection)+    registry <- lift (IO.acquirePreparedStatementRegistry)+    pqConnectionRef <- lift (newMVar pqConnection)+    pure (Connection pqConnectionRef integerDatetimes registry)++-- |+-- Release the connection.+release :: Connection -> IO ()+release (Connection pqConnectionRef _ _) =+  mask_ $ do+    nullConnection <- LibPQ.newNullConnection+    pqConnection <- swapMVar pqConnectionRef nullConnection+    IO.releaseConnection pqConnection++-- |+-- Execute an operation on the raw @libpq@ 'LibPQ.Connection'.+--+-- The access to the connection is exclusive.+withLibPQConnection :: Connection -> (LibPQ.Connection -> IO a) -> IO a+withLibPQConnection (Connection pqConnectionRef _ _) =+  withMVar pqConnectionRef
library/Hasql/Decoders.hs view
@@ -69,4 +69,4 @@   ) where -import Hasql.Private.Decoders+import Hasql.Decoders.All
+ library/Hasql/Decoders/All.hs view
@@ -0,0 +1,407 @@+-- |+-- A DSL for declaration of result decoders.+module Hasql.Decoders.All where++import qualified Data.Aeson as Aeson+import qualified Data.Vector.Generic as GenericVector+import qualified Hasql.Decoders.Array as Array+import qualified Hasql.Decoders.Composite as Composite+import qualified Hasql.Decoders.Result as Result+import qualified Hasql.Decoders.Results as Results+import qualified Hasql.Decoders.Row as Row+import qualified Hasql.Decoders.Value as Value+import Hasql.Prelude hiding (bool, maybe)+import qualified Hasql.Prelude as Prelude+import qualified Network.IP.Addr as NetworkIp+import qualified PostgreSQL.Binary.Decoding as A++-- * 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@.+{-# INLINEABLE noResult #-}+noResult :: Result ()+noResult = Result (Results.single Result.noResult)++-- |+-- 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.+{-# INLINEABLE singleRow #-}+singleRow :: Row a -> Result a+singleRow (Row row) = Result (Results.single (Result.single row))++refineResult :: (a -> Either Text b) -> Result a -> Result b+refineResult refiner (Result results) = Result (Results.refine refiner results)++-- ** Multi-row traversers++-- |+-- 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.+{-# 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.+{-# 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.+{-# 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.+{-# 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'+-- @+newtype Row a = Row (Row.Row a)+  deriving (Functor, Applicative, Monad, MonadFail)++-- |+-- Lift an individual value decoder to a composable row decoder.+{-# INLINEABLE 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)++type role Value representational++-- |+-- Decoder of the @BOOL@ values.+{-# INLINEABLE bool #-}+bool :: Value Bool+bool = Value (Value.decoder (const A.bool))++-- |+-- Decoder of the @INT2@ values.+{-# INLINEABLE int2 #-}+int2 :: Value Int16+int2 = Value (Value.decoder (const A.int))++-- |+-- Decoder of the @INT4@ values.+{-# INLINEABLE int4 #-}+int4 :: Value Int32+int4 = Value (Value.decoder (const A.int))++-- |+-- Decoder of the @INT8@ values.+{-# INLINEABLE int8 #-}+int8 :: Value Int64+int8 =+  {-# SCC "int8" #-}+  Value (Value.decoder (const ({-# SCC "int8.int" #-} A.int)))++-- |+-- Decoder of the @FLOAT4@ values.+{-# INLINEABLE float4 #-}+float4 :: Value Float+float4 = Value (Value.decoder (const A.float4))++-- |+-- Decoder of the @FLOAT8@ values.+{-# INLINEABLE float8 #-}+float8 :: Value Double+float8 = Value (Value.decoder (const A.float8))++-- |+-- Decoder of the @NUMERIC@ values.+{-# INLINEABLE numeric #-}+numeric :: Value Scientific+numeric = Value (Value.decoder (const A.numeric))++-- |+-- 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.+{-# INLINEABLE text #-}+text :: Value Text+text = Value (Value.decoder (const A.text_strict))++-- |+-- Decoder of the @BYTEA@ values.+{-# INLINEABLE bytea #-}+bytea :: Value ByteString+bytea = Value (Value.decoder (const A.bytea_strict))++-- |+-- Decoder of the @DATE@ values.+{-# INLINEABLE date #-}+date :: Value Day+date = Value (Value.decoder (const A.date))++-- |+-- Decoder of the @TIMESTAMP@ values.+{-# INLINEABLE timestamp #-}+timestamp :: Value 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.+{-# INLINEABLE timestamptz #-}+timestamptz :: Value UTCTime+timestamptz = Value (Value.decoder (Prelude.bool A.timestamptz_float A.timestamptz_int))++-- |+-- Decoder of the @TIME@ values.+{-# INLINEABLE time #-}+time :: Value 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.+{-# INLINEABLE timetz #-}+timetz :: Value (TimeOfDay, TimeZone)+timetz = Value (Value.decoder (Prelude.bool A.timetz_float A.timetz_int))++-- |+-- Decoder of the @INTERVAL@ values.+{-# INLINEABLE interval #-}+interval :: Value DiffTime+interval = Value (Value.decoder (Prelude.bool A.interval_float A.interval_int))++-- |+-- Decoder of the @UUID@ values.+{-# INLINEABLE uuid #-}+uuid :: Value UUID+uuid = Value (Value.decoder (const A.uuid))++-- |+-- Decoder of the @INET@ values.+{-# INLINEABLE inet #-}+inet :: Value (NetworkIp.NetAddr NetworkIp.IP)+inet = Value (Value.decoder (const A.inet))++-- |+-- Decoder of the @JSON@ values into a JSON AST.+{-# INLINEABLE json #-}+json :: Value Aeson.Value+json = Value (Value.decoder (const A.json_ast))++-- |+-- 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.+{-# INLINEABLE jsonb #-}+jsonb :: Value Aeson.Value+jsonb = Value (Value.decoder (const A.jsonb_ast))++-- |+-- 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.+{-# 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.+{-# 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'+-- @+{-# 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.+enum :: (Text -> Maybe a) -> Value a+enum mapping = Value (Value.decoder (const (A.enum mapping)))++-- |+-- 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'.+{-# 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.+{-# 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'))))+-- @+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'.+{-# 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.+{-# INLINEABLE 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, MonadFail)++-- |+-- 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))
+ library/Hasql/Decoders/Array.hs view
@@ -0,0 +1,28 @@+module Hasql.Decoders.Array where++import Hasql.Prelude+import qualified PostgreSQL.Binary.Decoding as A++newtype Array a+  = Array (ReaderT Bool A.Array a)+  deriving (Functor)++{-# INLINE run #-}+run :: Array a -> Bool -> A.Value a+run (Array imp) env =+  A.array (runReaderT imp env)++{-# INLINE dimension #-}+dimension :: (forall m. (Monad m) => Int -> m a -> m b) -> Array a -> Array b+dimension replicateM (Array imp) =+  Array $ ReaderT $ \env -> A.dimensionArray replicateM (runReaderT imp env)++{-# INLINE value #-}+value :: (Bool -> A.Value a) -> Array (Maybe a)+value decoder' =+  Array $ ReaderT $ A.nullableValueArray . decoder'++{-# INLINE nonNullValue #-}+nonNullValue :: (Bool -> A.Value a) -> Array a+nonNullValue decoder' =+  Array $ ReaderT $ A.valueArray . decoder'
+ library/Hasql/Decoders/Composite.hs view
@@ -0,0 +1,23 @@+module Hasql.Decoders.Composite where++import Hasql.Prelude+import qualified PostgreSQL.Binary.Decoding as A++newtype Composite a+  = Composite (ReaderT Bool A.Composite a)+  deriving (Functor, Applicative, Monad, MonadFail)++{-# INLINE run #-}+run :: Composite a -> Bool -> A.Value a+run (Composite imp) env =+  A.composite (runReaderT imp env)++{-# INLINE value #-}+value :: (Bool -> A.Value a) -> Composite (Maybe a)+value decoder' =+  Composite $ ReaderT $ A.nullableValueComposite . decoder'++{-# INLINE nonNullValue #-}+nonNullValue :: (Bool -> A.Value a) -> Composite a+nonNullValue decoder' =+  Composite $ ReaderT $ A.valueComposite . decoder'
+ library/Hasql/Decoders/Result.hs view
@@ -0,0 +1,228 @@+module Hasql.Decoders.Result where++import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec+import qualified Data.ByteString as ByteString+import qualified Data.Vector as Vector+import qualified Data.Vector.Mutable as MutableVector+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Hasql.Decoders.Row as Row+import Hasql.Errors+import Hasql.Prelude hiding (many, maybe)+import qualified Hasql.Prelude as Prelude++newtype Result a+  = Result (ReaderT (Bool, LibPQ.Result) (ExceptT ResultError IO) a)+  deriving (Functor, Applicative, Monad)++{-# INLINE run #-}+run :: Result a -> (Bool, LibPQ.Result) -> IO (Either ResultError a)+run (Result reader) env =+  runExceptT (runReaderT reader env)++{-# INLINE noResult #-}+noResult :: Result ()+noResult =+  checkExecStatus $ \case+    LibPQ.CommandOk -> True+    LibPQ.TuplesOk -> True+    _ -> False++{-# INLINE rowsAffected #-}+rowsAffected :: Result Int64+rowsAffected =+  do+    checkExecStatus $ \case+      LibPQ.CommandOk -> True+      _ -> False+    Result+      $ ReaderT+      $ \(_, result) ->+        ExceptT+          $ LibPQ.cmdTuples result+          & fmap cmdTuplesReader+  where+    cmdTuplesReader =+      notNothing >=> notEmpty >=> decimal+      where+        notNothing =+          Prelude.maybe (Left (UnexpectedResult "No bytes")) Right+        notEmpty bytes =+          if ByteString.null bytes+            then Left (UnexpectedResult "Empty bytes")+            else Right bytes+        decimal bytes =+          mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m))+            $ Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes++{-# INLINE checkExecStatus #-}+checkExecStatus :: (LibPQ.ExecStatus -> Bool) -> Result ()+checkExecStatus predicate =+  {-# SCC "checkExecStatus" #-}+  do+    status <- Result $ ReaderT $ \(_, result) -> lift $ LibPQ.resultStatus result+    unless (predicate status) $ do+      case status of+        LibPQ.BadResponse -> serverError+        LibPQ.NonfatalError -> serverError+        LibPQ.FatalError -> serverError+        LibPQ.EmptyQuery -> return ()+        _ -> 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+      position <-+        parsePosition <$> LibPQ.resultErrorField result LibPQ.DiagStatementPosition+      pure $ Left $ ServerError code message detail hint position+  where+    parsePosition = \case+      Nothing -> Nothing+      Just pos ->+        case Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) pos of+          Right pos -> Just pos+          _ -> Nothing++{-# INLINE maybe #-}+maybe :: Row.Row a -> Result (Maybe a)+maybe rowDec =+  do+    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)))+  where+    rowToInt (LibPQ.Row n) =+      fromIntegral n++{-# INLINE single #-}+single :: Row.Row a -> Result a+single rowDec =+  do+    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)))+  where+    rowToInt (LibPQ.Row n) =+      fromIntegral n++{-# INLINE vector #-}+vector :: Row.Row a -> Result (Vector a)+vector rowDec =+  do+    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)+  where+    rowToInt (LibPQ.Row n) =+      fromIntegral n+    intToRow =+      LibPQ.Row . fromIntegral++{-# INLINE foldl #-}+foldl :: (a -> b -> a) -> a -> Row.Row b -> Result a+foldl step init rowDec =+  {-# 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)+  where+    rowToInt (LibPQ.Row n) =+      fromIntegral n+    intToRow =+      LibPQ.Row . fromIntegral++{-# INLINE foldr #-}+foldr :: (b -> a -> a) -> a -> Row.Row b -> Result a+foldr step init rowDec =+  {-# 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)+  where+    rowToInt (LibPQ.Row n) =+      fromIntegral n+    intToRow =+      LibPQ.Row . fromIntegral
+ library/Hasql/Decoders/Results.hs view
@@ -0,0 +1,94 @@+-- |+-- 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.Decoders.Results where++import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Hasql.Decoders.Result as Result+import Hasql.Errors+import Hasql.Prelude hiding (many, maybe)+import qualified Hasql.Prelude as Prelude++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 =+  runExceptT (runReaderT stack env)++{-# INLINE clientError #-}+clientError :: Results a+clientError =+  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)++-- |+-- 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)++-- |+-- Fetch a single result.+{-# INLINE getResultMaybe #-}+getResultMaybe :: Results (Maybe LibPQ.Result)+getResultMaybe =+  Results $ ReaderT $ \(_, connection) -> lift $ LibPQ.getResult connection++{-# INLINE dropRemainders #-}+dropRemainders :: Results ()+dropRemainders =+  {-# SCC "dropRemainders" #-}+  Results $ ReaderT $ \(integerDatetimes, connection) -> loop integerDatetimes connection+  where+    loop integerDatetimes connection =+      getResultMaybe >>= Prelude.maybe (pure ()) onResult+      where+        getResultMaybe =+          lift $ LibPQ.getResult connection+        onResult result =+          loop integerDatetimes connection <* checkErrors+          where+            checkErrors =+              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
+ library/Hasql/Decoders/Row.hs view
@@ -0,0 +1,68 @@+module Hasql.Decoders.Row where++import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Hasql.Decoders.Value as Value+import Hasql.Errors+import Hasql.Prelude hiding (error)+import qualified PostgreSQL.Binary.Decoding as 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)++-- * Functions++{-# INLINE run #-}+run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either (Int, RowError) a)+run (Row impl) (result, row, columnsAmount, integerDatetimes) =+  do+    columnRef <- newIORef 0+    runExceptT (runReaderT impl (Env result row columnsAmount integerDatetimes columnRef)) >>= \case+      Left e -> do+        LibPQ.Col col <- readIORef columnRef+        -- -1 because succ is applied before the error is returned+        pure $ Left (fromIntegral col - 1, e)+      Right x -> pure $ Right x++{-# INLINE error #-}+error :: RowError -> Row a+error x =+  Row (ReaderT (const (ExceptT (pure (Left x)))))++-- |+-- Next value, decoded using the provided value decoder.+{-# INLINE value #-}+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)++-- |+-- Next value, decoded using the provided value decoder.+{-# INLINE nonNullValue #-}+nonNullValue :: Value.Value a -> Row a+nonNullValue valueDec =+  {-# SCC "nonNullValue" #-}+  value valueDec >>= maybe (error UnexpectedNull) pure
+ library/Hasql/Decoders/Value.hs view
@@ -0,0 +1,24 @@+module Hasql.Decoders.Value where++import Hasql.Prelude+import qualified PostgreSQL.Binary.Decoding as A++newtype Value a+  = Value (Bool -> A.Value a)+  deriving (Functor)++{-# INLINE run #-}+run :: Value a -> Bool -> A.Value a+run (Value imp) integerDatetimes =+  imp integerDatetimes++{-# INLINE decoder #-}+decoder :: (Bool -> A.Value a) -> Value a+decoder =+  {-# SCC "decoder" #-}+  Value++{-# INLINE decoderFn #-}+decoderFn :: (Bool -> ByteString -> Either Text a) -> Value a+decoderFn fn =+  Value $ \integerDatetimes -> A.fn $ fn integerDatetimes
library/Hasql/Encoders.hs view
@@ -60,4 +60,4 @@   ) where -import Hasql.Private.Encoders+import Hasql.Encoders.All
+ library/Hasql/Encoders/All.hs view
@@ -0,0 +1,423 @@+-- |+-- A DSL for declaration of query parameter encoders.+module Hasql.Encoders.All where++import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy as LazyByteString+import qualified Hasql.Encoders.Array as Array+import qualified Hasql.Encoders.Params as Params+import qualified Hasql.Encoders.Value as Value+import qualified Hasql.PTI as PTI+import Hasql.Prelude hiding (bool)+import qualified Hasql.Prelude as Prelude+import qualified Network.IP.Addr as NetworkIp+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"+-- @+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.+{-# INLINEABLE bool #-}+bool :: Value Bool+bool = Value (Value.unsafePTIWithShow PTI.bool (const A.bool))++-- |+-- Encoder of @INT2@ values.+{-# INLINEABLE int2 #-}+int2 :: Value Int16+int2 = Value (Value.unsafePTIWithShow PTI.int2 (const A.int2_int16))++-- |+-- Encoder of @INT4@ values.+{-# INLINEABLE int4 #-}+int4 :: Value Int32+int4 = Value (Value.unsafePTIWithShow PTI.int4 (const A.int4_int32))++-- |+-- Encoder of @INT8@ values.+{-# INLINEABLE int8 #-}+int8 :: Value Int64+int8 = Value (Value.unsafePTIWithShow PTI.int8 (const A.int8_int64))++-- |+-- Encoder of @FLOAT4@ values.+{-# INLINEABLE float4 #-}+float4 :: Value Float+float4 = Value (Value.unsafePTIWithShow PTI.float4 (const A.float4))++-- |+-- Encoder of @FLOAT8@ values.+{-# INLINEABLE float8 #-}+float8 :: Value Double+float8 = Value (Value.unsafePTIWithShow PTI.float8 (const A.float8))++-- |+-- Encoder of @NUMERIC@ values.+{-# INLINEABLE numeric #-}+numeric :: Value 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.+{-# INLINEABLE char #-}+char :: Value Char+char = Value (Value.unsafePTIWithShow PTI.text (const A.char_utf8))++-- |+-- Encoder of @TEXT@ values.+{-# INLINEABLE text #-}+text :: Value Text+text = Value (Value.unsafePTIWithShow PTI.text (const A.text_strict))++-- |+-- Encoder of @BYTEA@ values.+{-# INLINEABLE bytea #-}+bytea :: Value ByteString+bytea = Value (Value.unsafePTIWithShow PTI.bytea (const A.bytea_strict))++-- |+-- Encoder of @DATE@ values.+{-# INLINEABLE date #-}+date :: Value Day+date = Value (Value.unsafePTIWithShow PTI.date (const A.date))++-- |+-- Encoder of @TIMESTAMP@ values.+{-# INLINEABLE timestamp #-}+timestamp :: Value LocalTime+timestamp = Value (Value.unsafePTIWithShow PTI.timestamp (Prelude.bool A.timestamp_float A.timestamp_int))++-- |+-- Encoder of @TIMESTAMPTZ@ values.+{-# INLINEABLE timestamptz #-}+timestamptz :: Value UTCTime+timestamptz = Value (Value.unsafePTIWithShow PTI.timestamptz (Prelude.bool A.timestamptz_float A.timestamptz_int))++-- |+-- Encoder of @TIME@ values.+{-# INLINEABLE time #-}+time :: Value TimeOfDay+time = Value (Value.unsafePTIWithShow PTI.time (Prelude.bool A.time_float A.time_int))++-- |+-- Encoder of @TIMETZ@ values.+{-# INLINEABLE timetz #-}+timetz :: Value (TimeOfDay, TimeZone)+timetz = Value (Value.unsafePTIWithShow PTI.timetz (Prelude.bool A.timetz_float A.timetz_int))++-- |+-- Encoder of @INTERVAL@ values.+{-# INLINEABLE interval #-}+interval :: Value DiffTime+interval = Value (Value.unsafePTIWithShow PTI.interval (Prelude.bool A.interval_float A.interval_int))++-- |+-- Encoder of @UUID@ values.+{-# INLINEABLE uuid #-}+uuid :: Value UUID+uuid = Value (Value.unsafePTIWithShow PTI.uuid (const A.uuid))++-- |+-- Encoder of @INET@ values.+{-# INLINEABLE inet #-}+inet :: Value (NetworkIp.NetAddr NetworkIp.IP)+inet = Value (Value.unsafePTIWithShow PTI.inet (const A.inet))++-- |+-- Encoder of @JSON@ values from JSON AST.+{-# INLINEABLE json #-}+json :: Value Aeson.Value+json = Value (Value.unsafePTIWithShow PTI.json (const A.json_ast))++-- |+-- Encoder of @JSON@ values from raw JSON.+{-# INLINEABLE jsonBytes #-}+jsonBytes :: Value ByteString+jsonBytes = Value (Value.unsafePTIWithShow PTI.json (const A.json_bytes))++-- |+-- Encoder of @JSON@ values from raw JSON as lazy ByteString.+{-# INLINEABLE jsonLazyBytes #-}+jsonLazyBytes :: Value LazyByteString.ByteString+jsonLazyBytes = Value (Value.unsafePTIWithShow PTI.json (const A.json_bytes_lazy))++-- |+-- Encoder of @JSONB@ values from JSON AST.+{-# INLINEABLE jsonb #-}+jsonb :: Value Aeson.Value+jsonb = Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_ast))++-- |+-- Encoder of @JSONB@ values from raw JSON.+{-# INLINEABLE jsonbBytes #-}+jsonbBytes :: Value ByteString+jsonbBytes = Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_bytes))++-- |+-- Encoder of @JSONB@ values from raw JSON as lazy ByteString.+{-# INLINEABLE jsonbLazyBytes #-}+jsonbLazyBytes :: Value LazyByteString.ByteString+jsonbLazyBytes = Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_bytes_lazy))++-- |+-- Encoder of @OID@ values.+{-# INLINEABLE oid #-}+oid :: Value Int32+oid = Value (Value.unsafePTIWithShow PTI.oid (const A.int4_int32))++-- |+-- Encoder of @NAME@ values.+{-# INLINEABLE name #-}+name :: Value Text+name = Value (Value.unsafePTIWithShow PTI.name (const A.text_strict))++-- |+-- 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))++-- |+-- Variation of 'enum' with unknown OID.+-- This function does not identify the type to Postgres,+-- so Postgres must be able to derive the type from context.+-- When you find yourself in such situation just provide an explicit type in the query+-- using the :: operator.+{-# INLINEABLE unknownEnum #-}+unknownEnum :: (a -> Text) -> Value a+unknownEnum mapping = Value (Value.unsafePTI PTI.binaryUnknown (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.+--+-- __Warning:__ Do not use this as part of composite encoders like 'array' since+-- it is the only encoder that doesn't use the binary format.+{-# INLINEABLE unknown #-}+unknown :: Value ByteString+unknown = Value (Value.unsafePTIWithShow PTI.textUnknown (const A.bytea_strict))++-- |+-- Lift an array encoder into a value 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 composite encoder into a value encoder.+composite :: Composite a -> Value a+composite (Composite encode print) =+  Value (Value.unsafePTI PTI.binaryUnknown encodeValue printValue)+  where+    encodeValue idt val =+      A.composite $ encode val idt+    printValue val =+      "ROW (" <> C.intercalate ", " (print val) <> ")"++-- |+-- 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.+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'.+{-# INLINEABLE dimension #-}+dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c+dimension foldl (Array imp) = Array (Array.dimension foldl imp)++-- * Composite++-- |+-- Composite or row-types encoder.+data Composite a+  = Composite+      (a -> Bool -> A.Composite)+      (a -> [C.Builder])++instance Contravariant Composite where+  contramap f (Composite encode print) =+    Composite (encode . f) (print . f)++instance Divisible Composite where+  divide f (Composite encodeL printL) (Composite encodeR printR) =+    Composite+      (\val idt -> case f val of (lVal, rVal) -> encodeL lVal idt <> encodeR rVal idt)+      (\val -> case f val of (lVal, rVal) -> printL lVal <> printR rVal)+  conquer = mempty++instance Semigroup (Composite a) where+  Composite encodeL printL <> Composite encodeR printR =+    Composite+      (\val idt -> encodeL val idt <> encodeR val idt)+      (\val -> printL val <> printR val)++instance Monoid (Composite a) where+  mempty = Composite mempty mempty++-- | Single field of a row-type.+field :: NullableOrNot Value a -> Composite a+field = \case+  NonNullable (Value (Value.Value elementOID arrayOID encode print)) ->+    Composite+      (\val idt -> A.field (PTI.oidWord32 elementOID) (encode idt val))+      (\val -> [print val])+  Nullable (Value (Value.Value elementOID arrayOID encode print)) ->+    Composite+      ( \val idt -> case val of+          Nothing -> A.nullField (PTI.oidWord32 elementOID)+          Just val -> A.field (PTI.oidWord32 elementOID) (encode idt val)+      )+      ( \val ->+          case val of+            Nothing -> ["NULL"]+            Just val -> [print val]+      )
+ library/Hasql/Encoders/Array.hs view
@@ -0,0 +1,44 @@+module Hasql.Encoders.Array where++import qualified Hasql.PTI as B+import Hasql.Prelude+import qualified PostgreSQL.Binary.Encoding as A+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 =+  Array valueOID arrayOID (\params -> A.encodingArray . encoder params)++{-# 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++{-# 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
+ library/Hasql/Encoders/Params.hs view
@@ -0,0 +1,31 @@+module Hasql.Encoders.Params where++import qualified Database.PostgreSQL.LibPQ as A+import qualified Hasql.Encoders.Value as C+import qualified Hasql.PTI as D+import Hasql.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)+  deriving (Contravariant, Divisible, Decidable, Semigroup, Monoid)++value :: C.Value a -> Params a+value =+  contramap Just . nullableValue++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)
+ library/Hasql/Encoders/Value.hs view
@@ -0,0 +1,24 @@+module Hasql.Encoders.Value where++import qualified Hasql.PTI as PTI+import Hasql.Prelude+import qualified PostgreSQL.Binary.Encoding as B+import qualified Text.Builder as C++data Value a+  = Value PTI.OID PTI.OID (Bool -> a -> B.Encoding) (a -> C.Builder)++instance Contravariant Value where+  {-# INLINE contramap #-}+  contramap f (Value valueOID arrayOID encode render) =+    Value valueOID arrayOID (\integerDatetimes input -> encode integerDatetimes (f input)) (render . f)++{-# INLINE unsafePTI #-}+unsafePTI :: PTI.PTI -> (Bool -> a -> B.Encoding) -> (a -> C.Builder) -> Value a+unsafePTI pti =+  Value (PTI.ptiOID pti) (fromMaybe (error "No array OID") (PTI.ptiArrayOID pti))++{-# INLINE unsafePTIWithShow #-}+unsafePTIWithShow :: (Show a) => PTI.PTI -> (Bool -> a -> B.Encoding) -> Value a+unsafePTIWithShow pti encode =+  unsafePTI pti encode (C.string . show)
+ library/Hasql/Errors.hs view
@@ -0,0 +1,147 @@+-- |+-- 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.Errors where++import qualified Data.ByteString.Char8 as BC+import Hasql.Prelude++-- |+-- An error during the execution of a query.+-- Comes packed with the query template and a textual representation of the provided params.+data QueryError+  = QueryError ByteString [Text] CommandError+  deriving (Show, Eq, Typeable)++instance Exception QueryError where+  displayException (QueryError query params commandError) =+    let queryContext :: Maybe (ByteString, Int)+        queryContext = case commandError of+          ClientError _ -> Nothing+          ResultError resultError -> case resultError of+            ServerError _ message _ _ (Just position) -> Just (message, position)+            _ -> Nothing++        -- find the line number and position of the error+        findLineAndPos :: ByteString -> Int -> (Int, Int)+        findLineAndPos byteString errorPos =+          let (_, line, pos) =+                BC.foldl'+                  ( \(total, line, pos) c ->+                      case total + 1 of+                        0 -> (total, line, pos)+                        cursor+                          | cursor == errorPos -> (-1, line, pos + 1)+                          | c == '\n' -> (total + 1, line + 1, 0)+                          | otherwise -> (total + 1, line, pos + 1)+                  )+                  (0, 1, 0)+                  byteString+           in (line, pos)++        formatErrorContext :: ByteString -> ByteString -> Int -> ByteString+        formatErrorContext query message errorPos =+          let lines = BC.lines query+              (lineNum, linePos) = findLineAndPos query errorPos+           in BC.unlines (take lineNum lines)+                <> BC.replicate (linePos - 1) ' '+                <> "^ "+                <> message++        prettyQuery :: ByteString+        prettyQuery = case queryContext of+          Nothing -> query+          Just (message, pos) -> formatErrorContext query message pos+     in "QueryError!\n"+          <> "\n  Query:\n"+          <> BC.unpack prettyQuery+          <> "\n"+          <> "\n  Params: "+          <> show params+          <> "\n  Error: "+          <> case commandError of+            ClientError (Just message) -> "Client error: " <> show message+            ClientError Nothing -> "Unknown client error"+            ResultError resultError -> case resultError of+              ServerError code message details hint position ->+                "Server error "+                  <> BC.unpack code+                  <> ": "+                  <> BC.unpack message+                  <> maybe "" (\d -> "\n  Details: " <> BC.unpack d) details+                  <> maybe "" (\h -> "\n  Hint: " <> BC.unpack h) hint+              UnexpectedResult message -> "Unexpected result: " <> show message+              RowError row column rowError ->+                "Row error: " <> show row <> ":" <> show column <> " " <> show rowError+              UnexpectedAmountOfRows amount ->+                "Unexpected amount of rows: " <> show amount++-- |+-- An error of some command in the session.+data CommandError+  = -- |+    -- An error on the client-side,+    -- with a message generated by the \"libpq\" library.+    -- Usually indicates problems with connection.+    ClientError (Maybe ByteString)+  | -- |+    -- Some error with a command result.+    ResultError ResultError+  deriving (Show, Eq)++-- |+-- An error with a command result.+data ResultError+  = -- | An error reported by the DB.+    ServerError+      -- | __Code__. The SQLSTATE code for the error. It's recommended to use+      -- <http://hackage.haskell.org/package/postgresql-error-codes+      -- the "postgresql-error-codes" package> to work with those.+      ByteString+      -- | __Message__. The primary human-readable error message(typically one+      -- line). Always present.+      ByteString+      -- | __Details__. An optional secondary error message carrying more+      -- detail about the problem. Might run to multiple lines.+      (Maybe ByteString)+      -- | __Hint__. An optional suggestion on what to do about the problem.+      -- This is intended to differ from detail in that it offers advice+      -- (potentially inappropriate) rather than hard facts. Might run to+      -- multiple lines.+      (Maybe ByteString)+      -- | __Position__. Error cursor position as an index into the original+      -- statement string. Positions are measured in characters not bytes.+      (Maybe Int)+  | -- |+    -- The database returned an unexpected result.+    -- Indicates an improper statement or a schema mismatch.+    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+  deriving (Show, Eq)
+ library/Hasql/IO.hs view
@@ -0,0 +1,162 @@+-- |+-- An API of low-level IO operations.+module Hasql.IO where++import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Hasql.Commands as Commands+import qualified Hasql.Decoders.Result as ResultDecoders+import qualified Hasql.Decoders.Results as ResultsDecoders+import qualified Hasql.Encoders.Params as ParamsEncoders+import Hasql.Errors+import Hasql.Prelude+import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry++{-# INLINE acquireConnection #-}+acquireConnection :: ByteString -> IO LibPQ.Connection+acquireConnection =+  LibPQ.connectdb++{-# INLINE acquirePreparedStatementRegistry #-}+acquirePreparedStatementRegistry :: IO PreparedStatementRegistry.PreparedStatementRegistry+acquirePreparedStatementRegistry =+  PreparedStatementRegistry.new++{-# INLINE releaseConnection #-}+releaseConnection :: LibPQ.Connection -> IO ()+releaseConnection connection =+  LibPQ.finish connection++{-# INLINE checkConnectionStatus #-}+checkConnectionStatus :: LibPQ.Connection -> IO (Maybe (Maybe ByteString))+checkConnectionStatus c =+  do+    s <- LibPQ.status c+    case s of+      LibPQ.ConnectionOk -> return Nothing+      _ -> fmap Just (LibPQ.errorMessage c)++{-# INLINE checkServerVersion #-}+checkServerVersion :: LibPQ.Connection -> IO (Maybe Int)+checkServerVersion c =+  fmap (mfilter (< 80200) . Just) (LibPQ.serverVersion c)++{-# INLINE getIntegerDatetimes #-}+getIntegerDatetimes :: LibPQ.Connection -> IO Bool+getIntegerDatetimes c =+  fmap decodeValue $ LibPQ.parameterStatus c "integer_datetimes"+  where+    decodeValue =+      \case+        Just "on" -> True+        _ -> False++{-# INLINE initConnection #-}+initConnection :: LibPQ.Connection -> IO ()+initConnection c =+  void $ LibPQ.exec c (Commands.asBytes (Commands.setEncodersToUTF8 <> Commands.setMinClientMessagesToWarning))++{-# INLINE getResults #-}+getResults :: LibPQ.Connection -> Bool -> ResultsDecoders.Results a -> IO (Either CommandError a)+getResults connection integerDatetimes decoder =+  {-# SCC "getResults" #-}+  (<*) <$> get <*> dropRemainders+  where+    get =+      ResultsDecoders.run decoder (integerDatetimes, connection)+    dropRemainders =+      ResultsDecoders.run ResultsDecoders.dropRemainders (integerDatetimes, connection)++{-# INLINE getPreparedStatementKey #-}+getPreparedStatementKey ::+  LibPQ.Connection ->+  PreparedStatementRegistry.PreparedStatementRegistry ->+  ByteString ->+  [LibPQ.Oid] ->+  IO (Either CommandError ByteString)+getPreparedStatementKey connection registry template oidList =+  {-# SCC "getPreparedStatementKey" #-}+  PreparedStatementRegistry.update localKey onNewRemoteKey onOldRemoteKey registry+  where+    localKey =+      PreparedStatementRegistry.LocalKey template wordOIDList+      where+        wordOIDList =+          map (\(LibPQ.Oid x) -> fromIntegral x) oidList+    onNewRemoteKey key =+      do+        sent <- LibPQ.sendPrepare connection key template (mfilter (not . null) (Just oidList))+        let resultsDecoder =+              if sent+                then ResultsDecoders.single ResultDecoders.noResult+                else ResultsDecoders.clientError+        fmap resultsMapping $ getResults connection undefined resultsDecoder+      where+        resultsMapping =+          \case+            Left x -> (False, Left x)+            Right _ -> (True, Right key)+    onOldRemoteKey key =+      pure (pure key)++{-# INLINE checkedSend #-}+checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either CommandError ())+checkedSend connection send =+  send >>= \case+    False -> fmap (Left . ClientError) $ LibPQ.errorMessage connection+    True -> pure (Right ())++{-# INLINE sendPreparedParametricStatement #-}+sendPreparedParametricStatement ::+  LibPQ.Connection ->+  PreparedStatementRegistry.PreparedStatementRegistry ->+  Bool ->+  ByteString ->+  ParamsEncoders.Params a ->+  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++{-# INLINE sendUnpreparedParametricStatement #-}+sendUnpreparedParametricStatement ::+  LibPQ.Connection ->+  Bool ->+  ByteString ->+  ParamsEncoders.Params a ->+  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++{-# INLINE sendParametricStatement #-}+sendParametricStatement ::+  LibPQ.Connection ->+  Bool ->+  PreparedStatementRegistry.PreparedStatementRegistry ->+  ByteString ->+  ParamsEncoders.Params a ->+  Bool ->+  a ->+  IO (Either CommandError ())+sendParametricStatement connection integerDatetimes registry template encoder prepared params =+  {-# SCC "sendParametricStatement" #-}+  if prepared+    then sendPreparedParametricStatement connection registry integerDatetimes template encoder params+    else sendUnpreparedParametricStatement connection integerDatetimes template encoder params++{-# INLINE sendNonparametricStatement #-}+sendNonparametricStatement :: LibPQ.Connection -> ByteString -> IO (Either CommandError ())+sendNonparametricStatement connection sql =+  checkedSend connection $ LibPQ.sendQuery connection sql
+ library/Hasql/PTI.hs view
@@ -0,0 +1,230 @@+module Hasql.PTI where++import qualified Database.PostgreSQL.LibPQ as LibPQ+import Hasql.Prelude hiding (bool)++-- | A Postgresql type info+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}++mkOID :: LibPQ.Format -> Word32 -> OID+mkOID format x =+  OID x ((LibPQ.Oid . fromIntegral) x) format++mkPTI :: LibPQ.Format -> Word32 -> Maybe Word32 -> PTI+mkPTI format oid arrayOID =+  PTI (mkOID format oid) (fmap (mkOID format) arrayOID)++-- * Constants++abstime :: PTI+abstime = mkPTI LibPQ.Binary 702 (Just 1023)++aclitem :: PTI+aclitem = mkPTI LibPQ.Binary 1033 (Just 1034)++bit :: PTI+bit = mkPTI LibPQ.Binary 1560 (Just 1561)++bool :: PTI+bool = mkPTI LibPQ.Binary 16 (Just 1000)++box :: PTI+box = mkPTI LibPQ.Binary 603 (Just 1020)++bpchar :: PTI+bpchar = mkPTI LibPQ.Binary 1042 (Just 1014)++bytea :: PTI+bytea = mkPTI LibPQ.Binary 17 (Just 1001)++char :: PTI+char = mkPTI LibPQ.Binary 18 (Just 1002)++cid :: PTI+cid = mkPTI LibPQ.Binary 29 (Just 1012)++cidr :: PTI+cidr = mkPTI LibPQ.Binary 650 (Just 651)++circle :: PTI+circle = mkPTI LibPQ.Binary 718 (Just 719)++cstring :: PTI+cstring = mkPTI LibPQ.Binary 2275 (Just 1263)++date :: PTI+date = mkPTI LibPQ.Binary 1082 (Just 1182)++daterange :: PTI+daterange = mkPTI LibPQ.Binary 3912 (Just 3913)++float4 :: PTI+float4 = mkPTI LibPQ.Binary 700 (Just 1021)++float8 :: PTI+float8 = mkPTI LibPQ.Binary 701 (Just 1022)++gtsvector :: PTI+gtsvector = mkPTI LibPQ.Binary 3642 (Just 3644)++inet :: PTI+inet = mkPTI LibPQ.Binary 869 (Just 1041)++int2 :: PTI+int2 = mkPTI LibPQ.Binary 21 (Just 1005)++int2vector :: PTI+int2vector = mkPTI LibPQ.Binary 22 (Just 1006)++int4 :: PTI+int4 = mkPTI LibPQ.Binary 23 (Just 1007)++int4range :: PTI+int4range = mkPTI LibPQ.Binary 3904 (Just 3905)++int8 :: PTI+int8 = mkPTI LibPQ.Binary 20 (Just 1016)++int8range :: PTI+int8range = mkPTI LibPQ.Binary 3926 (Just 3927)++interval :: PTI+interval = mkPTI LibPQ.Binary 1186 (Just 1187)++json :: PTI+json = mkPTI LibPQ.Binary 114 (Just 199)++jsonb :: PTI+jsonb = mkPTI LibPQ.Binary 3802 (Just 3807)++line :: PTI+line = mkPTI LibPQ.Binary 628 (Just 629)++lseg :: PTI+lseg = mkPTI LibPQ.Binary 601 (Just 1018)++macaddr :: PTI+macaddr = mkPTI LibPQ.Binary 829 (Just 1040)++money :: PTI+money = mkPTI LibPQ.Binary 790 (Just 791)++name :: PTI+name = mkPTI LibPQ.Binary 19 (Just 1003)++numeric :: PTI+numeric = mkPTI LibPQ.Binary 1700 (Just 1231)++numrange :: PTI+numrange = mkPTI LibPQ.Binary 3906 (Just 3907)++oid :: PTI+oid = mkPTI LibPQ.Binary 26 (Just 1028)++oidvector :: PTI+oidvector = mkPTI LibPQ.Binary 30 (Just 1013)++path :: PTI+path = mkPTI LibPQ.Binary 602 (Just 1019)++point :: PTI+point = mkPTI LibPQ.Binary 600 (Just 1017)++polygon :: PTI+polygon = mkPTI LibPQ.Binary 604 (Just 1027)++record :: PTI+record = mkPTI LibPQ.Binary 2249 (Just 2287)++refcursor :: PTI+refcursor = mkPTI LibPQ.Binary 1790 (Just 2201)++regclass :: PTI+regclass = mkPTI LibPQ.Binary 2205 (Just 2210)++regconfig :: PTI+regconfig = mkPTI LibPQ.Binary 3734 (Just 3735)++regdictionary :: PTI+regdictionary = mkPTI LibPQ.Binary 3769 (Just 3770)++regoper :: PTI+regoper = mkPTI LibPQ.Binary 2203 (Just 2208)++regoperator :: PTI+regoperator = mkPTI LibPQ.Binary 2204 (Just 2209)++regproc :: PTI+regproc = mkPTI LibPQ.Binary 24 (Just 1008)++regprocedure :: PTI+regprocedure = mkPTI LibPQ.Binary 2202 (Just 2207)++regtype :: PTI+regtype = mkPTI LibPQ.Binary 2206 (Just 2211)++reltime :: PTI+reltime = mkPTI LibPQ.Binary 703 (Just 1024)++text :: PTI+text = mkPTI LibPQ.Binary 25 (Just 1009)++tid :: PTI+tid = mkPTI LibPQ.Binary 27 (Just 1010)++time :: PTI+time = mkPTI LibPQ.Binary 1083 (Just 1183)++timestamp :: PTI+timestamp = mkPTI LibPQ.Binary 1114 (Just 1115)++timestamptz :: PTI+timestamptz = mkPTI LibPQ.Binary 1184 (Just 1185)++timetz :: PTI+timetz = mkPTI LibPQ.Binary 1266 (Just 1270)++tinterval :: PTI+tinterval = mkPTI LibPQ.Binary 704 (Just 1025)++tsquery :: PTI+tsquery = mkPTI LibPQ.Binary 3615 (Just 3645)++tsrange :: PTI+tsrange = mkPTI LibPQ.Binary 3908 (Just 3909)++tstzrange :: PTI+tstzrange = mkPTI LibPQ.Binary 3910 (Just 3911)++tsvector :: PTI+tsvector = mkPTI LibPQ.Binary 3614 (Just 3643)++txid_snapshot :: PTI+txid_snapshot = mkPTI LibPQ.Binary 2970 (Just 2949)++textUnknown :: PTI+textUnknown = mkPTI LibPQ.Text 705 (Just 705)++binaryUnknown :: PTI+binaryUnknown = mkPTI LibPQ.Binary 705 (Just 705)++uuid :: PTI+uuid = mkPTI LibPQ.Binary 2950 (Just 2951)++varbit :: PTI+varbit = mkPTI LibPQ.Binary 1562 (Just 1563)++varchar :: PTI+varchar = mkPTI LibPQ.Binary 1043 (Just 1015)++void :: PTI+void = mkPTI LibPQ.Binary 2278 Nothing++xid :: PTI+xid = mkPTI LibPQ.Binary 28 (Just 1011)++xml :: PTI+xml = mkPTI LibPQ.Binary 142 (Just 143)
+ library/Hasql/Prelude.hs view
@@ -0,0 +1,137 @@+module Hasql.Prelude+  ( module Exports,+    LazyByteString,+    ByteStringBuilder,+    LazyText,+    TextBuilder,+    forMToZero_,+    forMFromZero_,+    strictCons,+    mapLeft,+  )+where++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, 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+import Data.Fixed as Exports+import Data.Foldable as Exports hiding (toList)+import Data.Function as Exports hiding (id, (.))+import Data.Functor as Exports hiding (unzip)+import Data.Functor.Compose as Exports+import Data.Functor.Contravariant as Exports+import Data.Functor.Contravariant.Divisible as Exports+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 (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.STRef as Exports+import Data.Scientific as Exports (Scientific)+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.Time as Exports+import Data.Traversable as Exports+import Data.Tuple as Exports+import Data.UUID as Exports (UUID)+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+import Debug.Trace as Exports+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, 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 System.Environment as Exports+import System.Exit as Exports+import System.IO as Exports (Handle, hClose)+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+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, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec)+import Text.Printf as Exports (hPrintf, printf)+import Unsafe.Coerce as Exports+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++type ByteStringBuilder =+  Data.ByteString.Builder.Builder++type LazyText =+  Data.Text.Lazy.Text++type TextBuilder =+  Data.Text.Lazy.Builder.Builder++{-# INLINE forMToZero_ #-}+forMToZero_ :: (Applicative m) => Int -> (Int -> m a) -> m ()+forMToZero_ !startN f =+  ($ pred startN) $ fix $ \loop !n -> if n >= 0 then f n *> loop (pred n) else pure ()++{-# INLINE forMFromZero_ #-}+forMFromZero_ :: (Applicative m) => Int -> (Int -> m a) -> m ()+forMFromZero_ !endN f =+  ($ 0) $ fix $ \loop !n -> if n < endN then f n *> loop (succ n) else pure ()++{-# INLINE strictCons #-}+strictCons :: a -> [a] -> [a]+strictCons !a b =+  let !c = a : b in c++{-# INLINE mapLeft #-}+mapLeft :: (a -> c) -> Either a b -> Either c b+mapLeft f =+  either (Left . f) Right
+ library/Hasql/PreparedStatementRegistry.hs view
@@ -0,0 +1,53 @@+module Hasql.PreparedStatementRegistry+  ( PreparedStatementRegistry,+    new,+    update,+    LocalKey (..),+  )+where++import qualified ByteString.StrictBuilder as B+import qualified Data.HashTable.IO as A+import Hasql.Prelude hiding (lookup)++data PreparedStatementRegistry+  = PreparedStatementRegistry !(A.BasicHashTable LocalKey ByteString) !(IORef Word)++{-# INLINEABLE new #-}+new :: IO PreparedStatementRegistry+new =+  PreparedStatementRegistry <$> A.new <*> newIORef 0++{-# 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+  where+    lookup =+      A.lookup table localKey+    new =+      readIORef counter >>= onN+      where+        onN n =+          do+            (save, result) <- onNewRemoteKey remoteKey+            when save $ do+              A.insert table localKey remoteKey+              writeIORef counter (succ n)+            return result+          where+            remoteKey =+              B.builderBytes . B.asciiIntegral $ n+    old =+      onOldRemoteKey++-- |+-- Local statement key.+data LocalKey+  = LocalKey !ByteString ![Word32]+  deriving (Show, Eq)++instance Hashable LocalKey where+  {-# INLINE hashWithSalt #-}+  hashWithSalt salt (LocalKey template types) =+    hashWithSalt salt template
− library/Hasql/Private/Commands.hs 
@@ -1,27 +0,0 @@-module Hasql.Private.Commands-  ( Commands,-    asBytes,-    setEncodersToUTF8,-    setMinClientMessagesToWarning,-  )-where--import qualified Data.ByteString.Builder as BB-import qualified Data.ByteString.Lazy as BL-import Hasql.Private.Prelude--newtype Commands-  = Commands (DList BB.Builder)-  deriving (Semigroup, Monoid)--asBytes :: Commands -> ByteString-asBytes (Commands list) =-  BL.toStrict $ BB.toLazyByteString $ foldMap (<> BB.char7 ';') $ list--setEncodersToUTF8 :: Commands-setEncodersToUTF8 =-  Commands (pure "SET client_encoding = 'UTF8'")--setMinClientMessagesToWarning :: Commands-setMinClientMessagesToWarning =-  Commands (pure "SET client_min_messages TO WARNING")
− library/Hasql/Private/Connection.hs 
@@ -1,50 +0,0 @@--- |--- This module provides a low-level effectful API dealing with the connections to the database.-module Hasql.Private.Connection where--import qualified Database.PostgreSQL.LibPQ as LibPQ-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---- |--- Possible details of the connection acquistion error.-type ConnectionError =-  Maybe ByteString---- |--- Acquire a connection using the provided settings encoded according to the PostgreSQL format.-acquire :: Settings.Settings -> IO (Either ConnectionError Connection)-acquire settings =-  {-# SCC "acquire" #-}-  runExceptT $ do-    pqConnection <- lift (IO.acquireConnection settings)-    lift (IO.checkConnectionStatus pqConnection) >>= traverse throwError-    lift (IO.initConnection pqConnection)-    integerDatetimes <- lift (IO.getIntegerDatetimes pqConnection)-    registry <- lift (IO.acquirePreparedStatementRegistry)-    pqConnectionRef <- lift (newMVar pqConnection)-    pure (Connection pqConnectionRef integerDatetimes registry)---- |--- Release the connection.-release :: Connection -> IO ()-release (Connection pqConnectionRef _ _) =-  mask_ $ do-    nullConnection <- LibPQ.newNullConnection-    pqConnection <- swapMVar pqConnectionRef nullConnection-    IO.releaseConnection pqConnection---- |--- Execute an operation on the raw @libpq@ 'LibPQ.Connection'.------ The access to the connection is exclusive.-withLibPQConnection :: Connection -> (LibPQ.Connection -> IO a) -> IO a-withLibPQConnection (Connection pqConnectionRef _ _) =-  withMVar pqConnectionRef
− library/Hasql/Private/Decoders.hs 
@@ -1,407 +0,0 @@--- |--- A DSL for declaration of result decoders.-module Hasql.Private.Decoders where--import qualified Data.Aeson as Aeson-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 Hasql.Private.Prelude hiding (bool, maybe)-import qualified Hasql.Private.Prelude as Prelude-import qualified Network.IP.Addr as NetworkIp-import qualified PostgreSQL.Binary.Decoding as A---- * 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@.-{-# INLINEABLE noResult #-}-noResult :: Result ()-noResult = Result (Results.single Result.noResult)---- |--- 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.-{-# INLINEABLE singleRow #-}-singleRow :: Row a -> Result a-singleRow (Row row) = Result (Results.single (Result.single row))--refineResult :: (a -> Either Text b) -> Result a -> Result b-refineResult refiner (Result results) = Result (Results.refine refiner results)---- ** Multi-row traversers---- |--- 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.-{-# 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.-{-# 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.-{-# 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.-{-# 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'--- @-newtype Row a = Row (Row.Row a)-  deriving (Functor, Applicative, Monad, MonadFail)---- |--- Lift an individual value decoder to a composable row decoder.-{-# INLINEABLE 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)--type role Value representational---- |--- Decoder of the @BOOL@ values.-{-# INLINEABLE bool #-}-bool :: Value Bool-bool = Value (Value.decoder (const A.bool))---- |--- Decoder of the @INT2@ values.-{-# INLINEABLE int2 #-}-int2 :: Value Int16-int2 = Value (Value.decoder (const A.int))---- |--- Decoder of the @INT4@ values.-{-# INLINEABLE int4 #-}-int4 :: Value Int32-int4 = Value (Value.decoder (const A.int))---- |--- Decoder of the @INT8@ values.-{-# INLINEABLE int8 #-}-int8 :: Value Int64-int8 =-  {-# SCC "int8" #-}-  Value (Value.decoder (const ({-# SCC "int8.int" #-} A.int)))---- |--- Decoder of the @FLOAT4@ values.-{-# INLINEABLE float4 #-}-float4 :: Value Float-float4 = Value (Value.decoder (const A.float4))---- |--- Decoder of the @FLOAT8@ values.-{-# INLINEABLE float8 #-}-float8 :: Value Double-float8 = Value (Value.decoder (const A.float8))---- |--- Decoder of the @NUMERIC@ values.-{-# INLINEABLE numeric #-}-numeric :: Value Scientific-numeric = Value (Value.decoder (const A.numeric))---- |--- 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.-{-# INLINEABLE text #-}-text :: Value Text-text = Value (Value.decoder (const A.text_strict))---- |--- Decoder of the @BYTEA@ values.-{-# INLINEABLE bytea #-}-bytea :: Value ByteString-bytea = Value (Value.decoder (const A.bytea_strict))---- |--- Decoder of the @DATE@ values.-{-# INLINEABLE date #-}-date :: Value Day-date = Value (Value.decoder (const A.date))---- |--- Decoder of the @TIMESTAMP@ values.-{-# INLINEABLE timestamp #-}-timestamp :: Value 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.-{-# INLINEABLE timestamptz #-}-timestamptz :: Value UTCTime-timestamptz = Value (Value.decoder (Prelude.bool A.timestamptz_float A.timestamptz_int))---- |--- Decoder of the @TIME@ values.-{-# INLINEABLE time #-}-time :: Value 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.-{-# INLINEABLE timetz #-}-timetz :: Value (TimeOfDay, TimeZone)-timetz = Value (Value.decoder (Prelude.bool A.timetz_float A.timetz_int))---- |--- Decoder of the @INTERVAL@ values.-{-# INLINEABLE interval #-}-interval :: Value DiffTime-interval = Value (Value.decoder (Prelude.bool A.interval_float A.interval_int))---- |--- Decoder of the @UUID@ values.-{-# INLINEABLE uuid #-}-uuid :: Value UUID-uuid = Value (Value.decoder (const A.uuid))---- |--- Decoder of the @INET@ values.-{-# INLINEABLE inet #-}-inet :: Value (NetworkIp.NetAddr NetworkIp.IP)-inet = Value (Value.decoder (const A.inet))---- |--- Decoder of the @JSON@ values into a JSON AST.-{-# INLINEABLE json #-}-json :: Value Aeson.Value-json = Value (Value.decoder (const A.json_ast))---- |--- 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.-{-# INLINEABLE jsonb #-}-jsonb :: Value Aeson.Value-jsonb = Value (Value.decoder (const A.jsonb_ast))---- |--- 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.-{-# 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.-{-# 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'--- @-{-# 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.-enum :: (Text -> Maybe a) -> Value a-enum mapping = Value (Value.decoder (const (A.enum mapping)))---- |--- 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'.-{-# 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.-{-# 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'))))--- @-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'.-{-# 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.-{-# INLINEABLE 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, MonadFail)---- |--- 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))
− library/Hasql/Private/Decoders/Array.hs 
@@ -1,28 +0,0 @@-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)-  deriving (Functor)--{-# INLINE run #-}-run :: Array a -> Bool -> A.Value a-run (Array imp) env =-  A.array (runReaderT imp env)--{-# INLINE dimension #-}-dimension :: (forall m. (Monad m) => Int -> m a -> m b) -> Array a -> Array b-dimension replicateM (Array imp) =-  Array $ ReaderT $ \env -> A.dimensionArray replicateM (runReaderT imp env)--{-# INLINE value #-}-value :: (Bool -> A.Value a) -> Array (Maybe a)-value decoder' =-  Array $ ReaderT $ A.nullableValueArray . decoder'--{-# INLINE nonNullValue #-}-nonNullValue :: (Bool -> A.Value a) -> Array a-nonNullValue decoder' =-  Array $ ReaderT $ A.valueArray . decoder'
− library/Hasql/Private/Decoders/Composite.hs 
@@ -1,23 +0,0 @@-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)-  deriving (Functor, Applicative, Monad, MonadFail)--{-# INLINE run #-}-run :: Composite a -> Bool -> A.Value a-run (Composite imp) env =-  A.composite (runReaderT imp env)--{-# INLINE value #-}-value :: (Bool -> A.Value a) -> Composite (Maybe a)-value decoder' =-  Composite $ ReaderT $ A.nullableValueComposite . decoder'--{-# INLINE nonNullValue #-}-nonNullValue :: (Bool -> A.Value a) -> Composite a-nonNullValue decoder' =-  Composite $ ReaderT $ A.valueComposite . decoder'
− library/Hasql/Private/Decoders/Result.hs 
@@ -1,228 +0,0 @@-module Hasql.Private.Decoders.Result where--import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec-import qualified Data.ByteString as ByteString-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)-  deriving (Functor, Applicative, Monad)--{-# INLINE run #-}-run :: Result a -> (Bool, LibPQ.Result) -> IO (Either ResultError a)-run (Result reader) env =-  runExceptT (runReaderT reader env)--{-# INLINE noResult #-}-noResult :: Result ()-noResult =-  checkExecStatus $ \case-    LibPQ.CommandOk -> True-    LibPQ.TuplesOk -> True-    _ -> False--{-# INLINE rowsAffected #-}-rowsAffected :: Result Int64-rowsAffected =-  do-    checkExecStatus $ \case-      LibPQ.CommandOk -> True-      _ -> False-    Result-      $ ReaderT-      $ \(_, result) ->-        ExceptT-          $ LibPQ.cmdTuples result-          & fmap cmdTuplesReader-  where-    cmdTuplesReader =-      notNothing >=> notEmpty >=> decimal-      where-        notNothing =-          Prelude.maybe (Left (UnexpectedResult "No bytes")) Right-        notEmpty bytes =-          if ByteString.null bytes-            then Left (UnexpectedResult "Empty bytes")-            else Right bytes-        decimal bytes =-          mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m))-            $ Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes--{-# INLINE checkExecStatus #-}-checkExecStatus :: (LibPQ.ExecStatus -> Bool) -> Result ()-checkExecStatus predicate =-  {-# SCC "checkExecStatus" #-}-  do-    status <- Result $ ReaderT $ \(_, result) -> lift $ LibPQ.resultStatus result-    unless (predicate status) $ do-      case status of-        LibPQ.BadResponse -> serverError-        LibPQ.NonfatalError -> serverError-        LibPQ.FatalError -> serverError-        LibPQ.EmptyQuery -> return ()-        _ -> 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-      position <--        parsePosition <$> LibPQ.resultErrorField result LibPQ.DiagStatementPosition-      pure $ Left $ ServerError code message detail hint position-  where-    parsePosition = \case-      Nothing -> Nothing-      Just pos ->-        case Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) pos of-          Right pos -> Just pos-          _ -> Nothing--{-# INLINE maybe #-}-maybe :: Row.Row a -> Result (Maybe a)-maybe rowDec =-  do-    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)))-  where-    rowToInt (LibPQ.Row n) =-      fromIntegral n--{-# INLINE single #-}-single :: Row.Row a -> Result a-single rowDec =-  do-    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)))-  where-    rowToInt (LibPQ.Row n) =-      fromIntegral n--{-# INLINE vector #-}-vector :: Row.Row a -> Result (Vector a)-vector rowDec =-  do-    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)-  where-    rowToInt (LibPQ.Row n) =-      fromIntegral n-    intToRow =-      LibPQ.Row . fromIntegral--{-# INLINE foldl #-}-foldl :: (a -> b -> a) -> a -> Row.Row b -> Result a-foldl step init rowDec =-  {-# 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)-  where-    rowToInt (LibPQ.Row n) =-      fromIntegral n-    intToRow =-      LibPQ.Row . fromIntegral--{-# INLINE foldr #-}-foldr :: (b -> a -> a) -> a -> Row.Row b -> Result a-foldr step init rowDec =-  {-# 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)-  where-    rowToInt (LibPQ.Row n) =-      fromIntegral n-    intToRow =-      LibPQ.Row . fromIntegral
− library/Hasql/Private/Decoders/Results.hs 
@@ -1,94 +0,0 @@--- |--- 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 qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified Hasql.Private.Decoders.Result as Result-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)-  deriving (Functor, Applicative, Monad)--{-# INLINE run #-}-run :: Results a -> (Bool, LibPQ.Connection) -> IO (Either CommandError a)-run (Results stack) env =-  runExceptT (runReaderT stack env)--{-# INLINE clientError #-}-clientError :: Results a-clientError =-  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)---- |--- 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)---- |--- Fetch a single result.-{-# INLINE getResultMaybe #-}-getResultMaybe :: Results (Maybe LibPQ.Result)-getResultMaybe =-  Results $ ReaderT $ \(_, connection) -> lift $ LibPQ.getResult connection--{-# INLINE dropRemainders #-}-dropRemainders :: Results ()-dropRemainders =-  {-# SCC "dropRemainders" #-}-  Results $ ReaderT $ \(integerDatetimes, connection) -> loop integerDatetimes connection-  where-    loop integerDatetimes connection =-      getResultMaybe >>= Prelude.maybe (pure ()) onResult-      where-        getResultMaybe =-          lift $ LibPQ.getResult connection-        onResult result =-          loop integerDatetimes connection <* checkErrors-          where-            checkErrors =-              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
− library/Hasql/Private/Decoders/Row.hs 
@@ -1,68 +0,0 @@-module Hasql.Private.Decoders.Row where--import qualified Database.PostgreSQL.LibPQ as LibPQ-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)-  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)---- * Functions--{-# INLINE run #-}-run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either (Int, RowError) a)-run (Row impl) (result, row, columnsAmount, integerDatetimes) =-  do-    columnRef <- newIORef 0-    runExceptT (runReaderT impl (Env result row columnsAmount integerDatetimes columnRef)) >>= \case-      Left e -> do-        LibPQ.Col col <- readIORef columnRef-        -- -1 because succ is applied before the error is returned-        pure $ Left (fromIntegral col - 1, e)-      Right x -> pure $ Right x--{-# INLINE error #-}-error :: RowError -> Row a-error x =-  Row (ReaderT (const (ExceptT (pure (Left x)))))---- |--- Next value, decoded using the provided value decoder.-{-# INLINE value #-}-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)---- |--- Next value, decoded using the provided value decoder.-{-# INLINE nonNullValue #-}-nonNullValue :: Value.Value a -> Row a-nonNullValue valueDec =-  {-# SCC "nonNullValue" #-}-  value valueDec >>= maybe (error UnexpectedNull) pure
− library/Hasql/Private/Decoders/Value.hs 
@@ -1,24 +0,0 @@-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)-  deriving (Functor)--{-# INLINE run #-}-run :: Value a -> Bool -> A.Value a-run (Value imp) integerDatetimes =-  imp integerDatetimes--{-# INLINE decoder #-}-decoder :: (Bool -> A.Value a) -> Value a-decoder =-  {-# SCC "decoder" #-}-  Value--{-# INLINE decoderFn #-}-decoderFn :: (Bool -> ByteString -> Either Text a) -> Value a-decoderFn fn =-  Value $ \integerDatetimes -> A.fn $ fn integerDatetimes
− library/Hasql/Private/Encoders.hs 
@@ -1,423 +0,0 @@--- |--- A DSL for declaration of query parameter encoders.-module Hasql.Private.Encoders where--import qualified Data.Aeson as Aeson-import qualified Data.ByteString.Lazy as LazyByteString-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.PTI as PTI-import Hasql.Private.Prelude hiding (bool)-import qualified Hasql.Private.Prelude as Prelude-import qualified Network.IP.Addr as NetworkIp-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"--- @-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.-{-# INLINEABLE bool #-}-bool :: Value Bool-bool = Value (Value.unsafePTIWithShow PTI.bool (const A.bool))---- |--- Encoder of @INT2@ values.-{-# INLINEABLE int2 #-}-int2 :: Value Int16-int2 = Value (Value.unsafePTIWithShow PTI.int2 (const A.int2_int16))---- |--- Encoder of @INT4@ values.-{-# INLINEABLE int4 #-}-int4 :: Value Int32-int4 = Value (Value.unsafePTIWithShow PTI.int4 (const A.int4_int32))---- |--- Encoder of @INT8@ values.-{-# INLINEABLE int8 #-}-int8 :: Value Int64-int8 = Value (Value.unsafePTIWithShow PTI.int8 (const A.int8_int64))---- |--- Encoder of @FLOAT4@ values.-{-# INLINEABLE float4 #-}-float4 :: Value Float-float4 = Value (Value.unsafePTIWithShow PTI.float4 (const A.float4))---- |--- Encoder of @FLOAT8@ values.-{-# INLINEABLE float8 #-}-float8 :: Value Double-float8 = Value (Value.unsafePTIWithShow PTI.float8 (const A.float8))---- |--- Encoder of @NUMERIC@ values.-{-# INLINEABLE numeric #-}-numeric :: Value 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.-{-# INLINEABLE char #-}-char :: Value Char-char = Value (Value.unsafePTIWithShow PTI.text (const A.char_utf8))---- |--- Encoder of @TEXT@ values.-{-# INLINEABLE text #-}-text :: Value Text-text = Value (Value.unsafePTIWithShow PTI.text (const A.text_strict))---- |--- Encoder of @BYTEA@ values.-{-# INLINEABLE bytea #-}-bytea :: Value ByteString-bytea = Value (Value.unsafePTIWithShow PTI.bytea (const A.bytea_strict))---- |--- Encoder of @DATE@ values.-{-# INLINEABLE date #-}-date :: Value Day-date = Value (Value.unsafePTIWithShow PTI.date (const A.date))---- |--- Encoder of @TIMESTAMP@ values.-{-# INLINEABLE timestamp #-}-timestamp :: Value LocalTime-timestamp = Value (Value.unsafePTIWithShow PTI.timestamp (Prelude.bool A.timestamp_float A.timestamp_int))---- |--- Encoder of @TIMESTAMPTZ@ values.-{-# INLINEABLE timestamptz #-}-timestamptz :: Value UTCTime-timestamptz = Value (Value.unsafePTIWithShow PTI.timestamptz (Prelude.bool A.timestamptz_float A.timestamptz_int))---- |--- Encoder of @TIME@ values.-{-# INLINEABLE time #-}-time :: Value TimeOfDay-time = Value (Value.unsafePTIWithShow PTI.time (Prelude.bool A.time_float A.time_int))---- |--- Encoder of @TIMETZ@ values.-{-# INLINEABLE timetz #-}-timetz :: Value (TimeOfDay, TimeZone)-timetz = Value (Value.unsafePTIWithShow PTI.timetz (Prelude.bool A.timetz_float A.timetz_int))---- |--- Encoder of @INTERVAL@ values.-{-# INLINEABLE interval #-}-interval :: Value DiffTime-interval = Value (Value.unsafePTIWithShow PTI.interval (Prelude.bool A.interval_float A.interval_int))---- |--- Encoder of @UUID@ values.-{-# INLINEABLE uuid #-}-uuid :: Value UUID-uuid = Value (Value.unsafePTIWithShow PTI.uuid (const A.uuid))---- |--- Encoder of @INET@ values.-{-# INLINEABLE inet #-}-inet :: Value (NetworkIp.NetAddr NetworkIp.IP)-inet = Value (Value.unsafePTIWithShow PTI.inet (const A.inet))---- |--- Encoder of @JSON@ values from JSON AST.-{-# INLINEABLE json #-}-json :: Value Aeson.Value-json = Value (Value.unsafePTIWithShow PTI.json (const A.json_ast))---- |--- Encoder of @JSON@ values from raw JSON.-{-# INLINEABLE jsonBytes #-}-jsonBytes :: Value ByteString-jsonBytes = Value (Value.unsafePTIWithShow PTI.json (const A.json_bytes))---- |--- Encoder of @JSON@ values from raw JSON as lazy ByteString.-{-# INLINEABLE jsonLazyBytes #-}-jsonLazyBytes :: Value LazyByteString.ByteString-jsonLazyBytes = Value (Value.unsafePTIWithShow PTI.json (const A.json_bytes_lazy))---- |--- Encoder of @JSONB@ values from JSON AST.-{-# INLINEABLE jsonb #-}-jsonb :: Value Aeson.Value-jsonb = Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_ast))---- |--- Encoder of @JSONB@ values from raw JSON.-{-# INLINEABLE jsonbBytes #-}-jsonbBytes :: Value ByteString-jsonbBytes = Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_bytes))---- |--- Encoder of @JSONB@ values from raw JSON as lazy ByteString.-{-# INLINEABLE jsonbLazyBytes #-}-jsonbLazyBytes :: Value LazyByteString.ByteString-jsonbLazyBytes = Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_bytes_lazy))---- |--- Encoder of @OID@ values.-{-# INLINEABLE oid #-}-oid :: Value Int32-oid = Value (Value.unsafePTIWithShow PTI.oid (const A.int4_int32))---- |--- Encoder of @NAME@ values.-{-# INLINEABLE name #-}-name :: Value Text-name = Value (Value.unsafePTIWithShow PTI.name (const A.text_strict))---- |--- 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))---- |--- Variation of 'enum' with unknown OID.--- This function does not identify the type to Postgres,--- so Postgres must be able to derive the type from context.--- When you find yourself in such situation just provide an explicit type in the query--- using the :: operator.-{-# INLINEABLE unknownEnum #-}-unknownEnum :: (a -> Text) -> Value a-unknownEnum mapping = Value (Value.unsafePTI PTI.binaryUnknown (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.------ __Warning:__ Do not use this as part of composite encoders like 'array' since--- it is the only encoder that doesn't use the binary format.-{-# INLINEABLE unknown #-}-unknown :: Value ByteString-unknown = Value (Value.unsafePTIWithShow PTI.textUnknown (const A.bytea_strict))---- |--- Lift an array encoder into a value 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 composite encoder into a value encoder.-composite :: Composite a -> Value a-composite (Composite encode print) =-  Value (Value.unsafePTI PTI.binaryUnknown encodeValue printValue)-  where-    encodeValue idt val =-      A.composite $ encode val idt-    printValue val =-      "ROW (" <> C.intercalate ", " (print val) <> ")"---- |--- 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.-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'.-{-# INLINEABLE dimension #-}-dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c-dimension foldl (Array imp) = Array (Array.dimension foldl imp)---- * Composite---- |--- Composite or row-types encoder.-data Composite a-  = Composite-      (a -> Bool -> A.Composite)-      (a -> [C.Builder])--instance Contravariant Composite where-  contramap f (Composite encode print) =-    Composite (encode . f) (print . f)--instance Divisible Composite where-  divide f (Composite encodeL printL) (Composite encodeR printR) =-    Composite-      (\val idt -> case f val of (lVal, rVal) -> encodeL lVal idt <> encodeR rVal idt)-      (\val -> case f val of (lVal, rVal) -> printL lVal <> printR rVal)-  conquer = mempty--instance Semigroup (Composite a) where-  Composite encodeL printL <> Composite encodeR printR =-    Composite-      (\val idt -> encodeL val idt <> encodeR val idt)-      (\val -> printL val <> printR val)--instance Monoid (Composite a) where-  mempty = Composite mempty mempty---- | Single field of a row-type.-field :: NullableOrNot Value a -> Composite a-field = \case-  NonNullable (Value (Value.Value elementOID arrayOID encode print)) ->-    Composite-      (\val idt -> A.field (PTI.oidWord32 elementOID) (encode idt val))-      (\val -> [print val])-  Nullable (Value (Value.Value elementOID arrayOID encode print)) ->-    Composite-      ( \val idt -> case val of-          Nothing -> A.nullField (PTI.oidWord32 elementOID)-          Just val -> A.field (PTI.oidWord32 elementOID) (encode idt val)-      )-      ( \val ->-          case val of-            Nothing -> ["NULL"]-            Just val -> [print val]-      )
− library/Hasql/Private/Encoders/Array.hs 
@@ -1,44 +0,0 @@-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 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 =-  Array valueOID arrayOID (\params -> A.encodingArray . encoder params)--{-# 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--{-# 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
− library/Hasql/Private/Encoders/Params.hs 
@@ -1,31 +0,0 @@-module Hasql.Private.Encoders.Params where--import qualified Database.PostgreSQL.LibPQ as A-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)-  deriving (Contravariant, Divisible, Decidable, Semigroup, Monoid)--value :: C.Value a -> Params a-value =-  contramap Just . nullableValue--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)
− library/Hasql/Private/Encoders/Value.hs 
@@ -1,24 +0,0 @@-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 Text.Builder as C--data Value a-  = Value PTI.OID PTI.OID (Bool -> a -> B.Encoding) (a -> C.Builder)--instance Contravariant Value where-  {-# INLINE contramap #-}-  contramap f (Value valueOID arrayOID encode render) =-    Value valueOID arrayOID (\integerDatetimes input -> encode integerDatetimes (f input)) (render . f)--{-# INLINE unsafePTI #-}-unsafePTI :: PTI.PTI -> (Bool -> a -> B.Encoding) -> (a -> C.Builder) -> Value a-unsafePTI pti =-  Value (PTI.ptiOID pti) (fromMaybe (error "No array OID") (PTI.ptiArrayOID pti))--{-# INLINE unsafePTIWithShow #-}-unsafePTIWithShow :: (Show a) => PTI.PTI -> (Bool -> a -> B.Encoding) -> Value a-unsafePTIWithShow pti encode =-  unsafePTI pti encode (C.string . show)
− library/Hasql/Private/Errors.hs 
@@ -1,147 +0,0 @@--- |--- 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 qualified Data.ByteString.Char8 as BC-import Hasql.Private.Prelude---- |--- An error during the execution of a query.--- Comes packed with the query template and a textual representation of the provided params.-data QueryError-  = QueryError ByteString [Text] CommandError-  deriving (Show, Eq, Typeable)--instance Exception QueryError where-  displayException (QueryError query params commandError) =-    let queryContext :: Maybe (ByteString, Int)-        queryContext = case commandError of-          ClientError _ -> Nothing-          ResultError resultError -> case resultError of-            ServerError _ message _ _ (Just position) -> Just (message, position)-            _ -> Nothing--        -- find the line number and position of the error-        findLineAndPos :: ByteString -> Int -> (Int, Int)-        findLineAndPos byteString errorPos =-          let (_, line, pos) =-                BC.foldl'-                  ( \(total, line, pos) c ->-                      case total + 1 of-                        0 -> (total, line, pos)-                        cursor-                          | cursor == errorPos -> (-1, line, pos + 1)-                          | c == '\n' -> (total + 1, line + 1, 0)-                          | otherwise -> (total + 1, line, pos + 1)-                  )-                  (0, 1, 0)-                  byteString-           in (line, pos)--        formatErrorContext :: ByteString -> ByteString -> Int -> ByteString-        formatErrorContext query message errorPos =-          let lines = BC.lines query-              (lineNum, linePos) = findLineAndPos query errorPos-           in BC.unlines (take lineNum lines)-                <> BC.replicate (linePos - 1) ' '-                <> "^ "-                <> message--        prettyQuery :: ByteString-        prettyQuery = case queryContext of-          Nothing -> query-          Just (message, pos) -> formatErrorContext query message pos-     in "QueryError!\n"-          <> "\n  Query:\n"-          <> BC.unpack prettyQuery-          <> "\n"-          <> "\n  Params: "-          <> show params-          <> "\n  Error: "-          <> case commandError of-            ClientError (Just message) -> "Client error: " <> show message-            ClientError Nothing -> "Unknown client error"-            ResultError resultError -> case resultError of-              ServerError code message details hint position ->-                "Server error "-                  <> BC.unpack code-                  <> ": "-                  <> BC.unpack message-                  <> maybe "" (\d -> "\n  Details: " <> BC.unpack d) details-                  <> maybe "" (\h -> "\n  Hint: " <> BC.unpack h) hint-              UnexpectedResult message -> "Unexpected result: " <> show message-              RowError row column rowError ->-                "Row error: " <> show row <> ":" <> show column <> " " <> show rowError-              UnexpectedAmountOfRows amount ->-                "Unexpected amount of rows: " <> show amount---- |--- An error of some command in the session.-data CommandError-  = -- |-    -- An error on the client-side,-    -- with a message generated by the \"libpq\" library.-    -- Usually indicates problems with connection.-    ClientError (Maybe ByteString)-  | -- |-    -- Some error with a command result.-    ResultError ResultError-  deriving (Show, Eq)---- |--- An error with a command result.-data ResultError-  = -- | An error reported by the DB.-    ServerError-      -- | __Code__. The SQLSTATE code for the error. It's recommended to use-      -- <http://hackage.haskell.org/package/postgresql-error-codes-      -- the "postgresql-error-codes" package> to work with those.-      ByteString-      -- | __Message__. The primary human-readable error message(typically one-      -- line). Always present.-      ByteString-      -- | __Details__. An optional secondary error message carrying more-      -- detail about the problem. Might run to multiple lines.-      (Maybe ByteString)-      -- | __Hint__. An optional suggestion on what to do about the problem.-      -- This is intended to differ from detail in that it offers advice-      -- (potentially inappropriate) rather than hard facts. Might run to-      -- multiple lines.-      (Maybe ByteString)-      -- | __Position__. Error cursor position as an index into the original-      -- statement string. Positions are measured in characters not bytes.-      (Maybe Int)-  | -- |-    -- The database returned an unexpected result.-    -- Indicates an improper statement or a schema mismatch.-    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-  deriving (Show, Eq)
− library/Hasql/Private/IO.hs 
@@ -1,162 +0,0 @@--- |--- An API of low-level IO operations.-module Hasql.Private.IO where--import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified Hasql.Private.Commands as Commands-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 Hasql.Private.Errors-import Hasql.Private.Prelude-import qualified Hasql.Private.PreparedStatementRegistry as PreparedStatementRegistry--{-# INLINE acquireConnection #-}-acquireConnection :: ByteString -> IO LibPQ.Connection-acquireConnection =-  LibPQ.connectdb--{-# INLINE acquirePreparedStatementRegistry #-}-acquirePreparedStatementRegistry :: IO PreparedStatementRegistry.PreparedStatementRegistry-acquirePreparedStatementRegistry =-  PreparedStatementRegistry.new--{-# INLINE releaseConnection #-}-releaseConnection :: LibPQ.Connection -> IO ()-releaseConnection connection =-  LibPQ.finish connection--{-# INLINE checkConnectionStatus #-}-checkConnectionStatus :: LibPQ.Connection -> IO (Maybe (Maybe ByteString))-checkConnectionStatus c =-  do-    s <- LibPQ.status c-    case s of-      LibPQ.ConnectionOk -> return Nothing-      _ -> fmap Just (LibPQ.errorMessage c)--{-# INLINE checkServerVersion #-}-checkServerVersion :: LibPQ.Connection -> IO (Maybe Int)-checkServerVersion c =-  fmap (mfilter (< 80200) . Just) (LibPQ.serverVersion c)--{-# INLINE getIntegerDatetimes #-}-getIntegerDatetimes :: LibPQ.Connection -> IO Bool-getIntegerDatetimes c =-  fmap decodeValue $ LibPQ.parameterStatus c "integer_datetimes"-  where-    decodeValue =-      \case-        Just "on" -> True-        _ -> False--{-# INLINE initConnection #-}-initConnection :: LibPQ.Connection -> IO ()-initConnection c =-  void $ LibPQ.exec c (Commands.asBytes (Commands.setEncodersToUTF8 <> Commands.setMinClientMessagesToWarning))--{-# INLINE getResults #-}-getResults :: LibPQ.Connection -> Bool -> ResultsDecoders.Results a -> IO (Either CommandError a)-getResults connection integerDatetimes decoder =-  {-# SCC "getResults" #-}-  (<*) <$> get <*> dropRemainders-  where-    get =-      ResultsDecoders.run decoder (integerDatetimes, connection)-    dropRemainders =-      ResultsDecoders.run ResultsDecoders.dropRemainders (integerDatetimes, connection)--{-# INLINE getPreparedStatementKey #-}-getPreparedStatementKey ::-  LibPQ.Connection ->-  PreparedStatementRegistry.PreparedStatementRegistry ->-  ByteString ->-  [LibPQ.Oid] ->-  IO (Either CommandError ByteString)-getPreparedStatementKey connection registry template oidList =-  {-# SCC "getPreparedStatementKey" #-}-  PreparedStatementRegistry.update localKey onNewRemoteKey onOldRemoteKey registry-  where-    localKey =-      PreparedStatementRegistry.LocalKey template wordOIDList-      where-        wordOIDList =-          map (\(LibPQ.Oid x) -> fromIntegral x) oidList-    onNewRemoteKey key =-      do-        sent <- LibPQ.sendPrepare connection key template (mfilter (not . null) (Just oidList))-        let resultsDecoder =-              if sent-                then ResultsDecoders.single ResultDecoders.noResult-                else ResultsDecoders.clientError-        fmap resultsMapping $ getResults connection undefined resultsDecoder-      where-        resultsMapping =-          \case-            Left x -> (False, Left x)-            Right _ -> (True, Right key)-    onOldRemoteKey key =-      pure (pure key)--{-# INLINE checkedSend #-}-checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either CommandError ())-checkedSend connection send =-  send >>= \case-    False -> fmap (Left . ClientError) $ LibPQ.errorMessage connection-    True -> pure (Right ())--{-# INLINE sendPreparedParametricStatement #-}-sendPreparedParametricStatement ::-  LibPQ.Connection ->-  PreparedStatementRegistry.PreparedStatementRegistry ->-  Bool ->-  ByteString ->-  ParamsEncoders.Params a ->-  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--{-# INLINE sendUnpreparedParametricStatement #-}-sendUnpreparedParametricStatement ::-  LibPQ.Connection ->-  Bool ->-  ByteString ->-  ParamsEncoders.Params a ->-  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--{-# INLINE sendParametricStatement #-}-sendParametricStatement ::-  LibPQ.Connection ->-  Bool ->-  PreparedStatementRegistry.PreparedStatementRegistry ->-  ByteString ->-  ParamsEncoders.Params a ->-  Bool ->-  a ->-  IO (Either CommandError ())-sendParametricStatement connection integerDatetimes registry template encoder prepared params =-  {-# SCC "sendParametricStatement" #-}-  if prepared-    then sendPreparedParametricStatement connection registry integerDatetimes template encoder params-    else sendUnpreparedParametricStatement connection integerDatetimes template encoder params--{-# INLINE sendNonparametricStatement #-}-sendNonparametricStatement :: LibPQ.Connection -> ByteString -> IO (Either CommandError ())-sendNonparametricStatement connection sql =-  checkedSend connection $ LibPQ.sendQuery connection sql
− library/Hasql/Private/PTI.hs 
@@ -1,230 +0,0 @@-module Hasql.Private.PTI where--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)}---- | A Word32 and a LibPQ representation of an OID-data OID = OID {oidWord32 :: !Word32, oidPQ :: !LibPQ.Oid, oidFormat :: !LibPQ.Format}--mkOID :: LibPQ.Format -> Word32 -> OID-mkOID format x =-  OID x ((LibPQ.Oid . fromIntegral) x) format--mkPTI :: LibPQ.Format -> Word32 -> Maybe Word32 -> PTI-mkPTI format oid arrayOID =-  PTI (mkOID format oid) (fmap (mkOID format) arrayOID)---- * Constants--abstime :: PTI-abstime = mkPTI LibPQ.Binary 702 (Just 1023)--aclitem :: PTI-aclitem = mkPTI LibPQ.Binary 1033 (Just 1034)--bit :: PTI-bit = mkPTI LibPQ.Binary 1560 (Just 1561)--bool :: PTI-bool = mkPTI LibPQ.Binary 16 (Just 1000)--box :: PTI-box = mkPTI LibPQ.Binary 603 (Just 1020)--bpchar :: PTI-bpchar = mkPTI LibPQ.Binary 1042 (Just 1014)--bytea :: PTI-bytea = mkPTI LibPQ.Binary 17 (Just 1001)--char :: PTI-char = mkPTI LibPQ.Binary 18 (Just 1002)--cid :: PTI-cid = mkPTI LibPQ.Binary 29 (Just 1012)--cidr :: PTI-cidr = mkPTI LibPQ.Binary 650 (Just 651)--circle :: PTI-circle = mkPTI LibPQ.Binary 718 (Just 719)--cstring :: PTI-cstring = mkPTI LibPQ.Binary 2275 (Just 1263)--date :: PTI-date = mkPTI LibPQ.Binary 1082 (Just 1182)--daterange :: PTI-daterange = mkPTI LibPQ.Binary 3912 (Just 3913)--float4 :: PTI-float4 = mkPTI LibPQ.Binary 700 (Just 1021)--float8 :: PTI-float8 = mkPTI LibPQ.Binary 701 (Just 1022)--gtsvector :: PTI-gtsvector = mkPTI LibPQ.Binary 3642 (Just 3644)--inet :: PTI-inet = mkPTI LibPQ.Binary 869 (Just 1041)--int2 :: PTI-int2 = mkPTI LibPQ.Binary 21 (Just 1005)--int2vector :: PTI-int2vector = mkPTI LibPQ.Binary 22 (Just 1006)--int4 :: PTI-int4 = mkPTI LibPQ.Binary 23 (Just 1007)--int4range :: PTI-int4range = mkPTI LibPQ.Binary 3904 (Just 3905)--int8 :: PTI-int8 = mkPTI LibPQ.Binary 20 (Just 1016)--int8range :: PTI-int8range = mkPTI LibPQ.Binary 3926 (Just 3927)--interval :: PTI-interval = mkPTI LibPQ.Binary 1186 (Just 1187)--json :: PTI-json = mkPTI LibPQ.Binary 114 (Just 199)--jsonb :: PTI-jsonb = mkPTI LibPQ.Binary 3802 (Just 3807)--line :: PTI-line = mkPTI LibPQ.Binary 628 (Just 629)--lseg :: PTI-lseg = mkPTI LibPQ.Binary 601 (Just 1018)--macaddr :: PTI-macaddr = mkPTI LibPQ.Binary 829 (Just 1040)--money :: PTI-money = mkPTI LibPQ.Binary 790 (Just 791)--name :: PTI-name = mkPTI LibPQ.Binary 19 (Just 1003)--numeric :: PTI-numeric = mkPTI LibPQ.Binary 1700 (Just 1231)--numrange :: PTI-numrange = mkPTI LibPQ.Binary 3906 (Just 3907)--oid :: PTI-oid = mkPTI LibPQ.Binary 26 (Just 1028)--oidvector :: PTI-oidvector = mkPTI LibPQ.Binary 30 (Just 1013)--path :: PTI-path = mkPTI LibPQ.Binary 602 (Just 1019)--point :: PTI-point = mkPTI LibPQ.Binary 600 (Just 1017)--polygon :: PTI-polygon = mkPTI LibPQ.Binary 604 (Just 1027)--record :: PTI-record = mkPTI LibPQ.Binary 2249 (Just 2287)--refcursor :: PTI-refcursor = mkPTI LibPQ.Binary 1790 (Just 2201)--regclass :: PTI-regclass = mkPTI LibPQ.Binary 2205 (Just 2210)--regconfig :: PTI-regconfig = mkPTI LibPQ.Binary 3734 (Just 3735)--regdictionary :: PTI-regdictionary = mkPTI LibPQ.Binary 3769 (Just 3770)--regoper :: PTI-regoper = mkPTI LibPQ.Binary 2203 (Just 2208)--regoperator :: PTI-regoperator = mkPTI LibPQ.Binary 2204 (Just 2209)--regproc :: PTI-regproc = mkPTI LibPQ.Binary 24 (Just 1008)--regprocedure :: PTI-regprocedure = mkPTI LibPQ.Binary 2202 (Just 2207)--regtype :: PTI-regtype = mkPTI LibPQ.Binary 2206 (Just 2211)--reltime :: PTI-reltime = mkPTI LibPQ.Binary 703 (Just 1024)--text :: PTI-text = mkPTI LibPQ.Binary 25 (Just 1009)--tid :: PTI-tid = mkPTI LibPQ.Binary 27 (Just 1010)--time :: PTI-time = mkPTI LibPQ.Binary 1083 (Just 1183)--timestamp :: PTI-timestamp = mkPTI LibPQ.Binary 1114 (Just 1115)--timestamptz :: PTI-timestamptz = mkPTI LibPQ.Binary 1184 (Just 1185)--timetz :: PTI-timetz = mkPTI LibPQ.Binary 1266 (Just 1270)--tinterval :: PTI-tinterval = mkPTI LibPQ.Binary 704 (Just 1025)--tsquery :: PTI-tsquery = mkPTI LibPQ.Binary 3615 (Just 3645)--tsrange :: PTI-tsrange = mkPTI LibPQ.Binary 3908 (Just 3909)--tstzrange :: PTI-tstzrange = mkPTI LibPQ.Binary 3910 (Just 3911)--tsvector :: PTI-tsvector = mkPTI LibPQ.Binary 3614 (Just 3643)--txid_snapshot :: PTI-txid_snapshot = mkPTI LibPQ.Binary 2970 (Just 2949)--textUnknown :: PTI-textUnknown = mkPTI LibPQ.Text 705 (Just 705)--binaryUnknown :: PTI-binaryUnknown = mkPTI LibPQ.Binary 705 (Just 705)--uuid :: PTI-uuid = mkPTI LibPQ.Binary 2950 (Just 2951)--varbit :: PTI-varbit = mkPTI LibPQ.Binary 1562 (Just 1563)--varchar :: PTI-varchar = mkPTI LibPQ.Binary 1043 (Just 1015)--void :: PTI-void = mkPTI LibPQ.Binary 2278 Nothing--xid :: PTI-xid = mkPTI LibPQ.Binary 28 (Just 1011)--xml :: PTI-xml = mkPTI LibPQ.Binary 142 (Just 143)
− library/Hasql/Private/Prelude.hs 
@@ -1,137 +0,0 @@-module Hasql.Private.Prelude-  ( module Exports,-    LazyByteString,-    ByteStringBuilder,-    LazyText,-    TextBuilder,-    forMToZero_,-    forMFromZero_,-    strictCons,-    mapLeft,-  )-where--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, 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-import Data.Fixed as Exports-import Data.Foldable as Exports hiding (toList)-import Data.Function as Exports hiding (id, (.))-import Data.Functor as Exports hiding (unzip)-import Data.Functor.Compose as Exports-import Data.Functor.Contravariant as Exports-import Data.Functor.Contravariant.Divisible as Exports-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 (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.STRef as Exports-import Data.Scientific as Exports (Scientific)-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.Time as Exports-import Data.Traversable as Exports-import Data.Tuple as Exports-import Data.UUID as Exports (UUID)-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-import Debug.Trace as Exports-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, 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 System.Environment as Exports-import System.Exit as Exports-import System.IO as Exports (Handle, hClose)-import System.IO.Error as Exports-import System.IO.Unsafe as Exports-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, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec)-import Text.Printf as Exports (hPrintf, printf)-import Unsafe.Coerce as Exports-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--type ByteStringBuilder =-  Data.ByteString.Builder.Builder--type LazyText =-  Data.Text.Lazy.Text--type TextBuilder =-  Data.Text.Lazy.Builder.Builder--{-# INLINE forMToZero_ #-}-forMToZero_ :: (Applicative m) => Int -> (Int -> m a) -> m ()-forMToZero_ !startN f =-  ($ pred startN) $ fix $ \loop !n -> if n >= 0 then f n *> loop (pred n) else pure ()--{-# INLINE forMFromZero_ #-}-forMFromZero_ :: (Applicative m) => Int -> (Int -> m a) -> m ()-forMFromZero_ !endN f =-  ($ 0) $ fix $ \loop !n -> if n < endN then f n *> loop (succ n) else pure ()--{-# INLINE strictCons #-}-strictCons :: a -> [a] -> [a]-strictCons !a b =-  let !c = a : b in c--{-# INLINE mapLeft #-}-mapLeft :: (a -> c) -> Either a b -> Either c b-mapLeft f =-  either (Left . f) Right
− library/Hasql/Private/PreparedStatementRegistry.hs 
@@ -1,53 +0,0 @@-module Hasql.Private.PreparedStatementRegistry-  ( PreparedStatementRegistry,-    new,-    update,-    LocalKey (..),-  )-where--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)--{-# INLINEABLE new #-}-new :: IO PreparedStatementRegistry-new =-  PreparedStatementRegistry <$> A.new <*> newIORef 0--{-# 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-  where-    lookup =-      A.lookup table localKey-    new =-      readIORef counter >>= onN-      where-        onN n =-          do-            (save, result) <- onNewRemoteKey remoteKey-            when save $ do-              A.insert table localKey remoteKey-              writeIORef counter (succ n)-            return result-          where-            remoteKey =-              B.builderBytes . B.asciiIntegral $ n-    old =-      onOldRemoteKey---- |--- Local statement key.-data LocalKey-  = LocalKey !ByteString ![Word32]-  deriving (Show, Eq)--instance Hashable LocalKey where-  {-# INLINE hashWithSalt #-}-  hashWithSalt salt (LocalKey template types) =-    hashWithSalt salt template
− library/Hasql/Private/Session.hs 
@@ -1,65 +0,0 @@-module Hasql.Private.Session where--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.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)-  deriving (Functor, Applicative, Monad, MonadError QueryError, MonadIO, MonadReader Connection.Connection)---- |--- Executes a bunch of commands on the provided connection.-run :: Session a -> Connection.Connection -> IO (Either QueryError a)-run (Session impl) connection =-  runExceptT-    $ runReaderT impl connection---- |--- Possibly a multi-statement query,--- which however cannot be parameterized or prepared,--- 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-  where-    decoder =-      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 (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-  where-    inputReps =-      let Encoders.Params.Params (Op encoderOp) = paramsEncoder-          step (_, _, _, rendering) acc =-            rendering : acc-       in foldr step [] (encoderOp input)
− library/Hasql/Private/Settings.hs 
@@ -1,39 +0,0 @@-module Hasql.Private.Settings where--import qualified Data.ByteString as B-import qualified Data.ByteString.Builder as BB-import qualified Data.ByteString.Lazy as BL-import Hasql.Private.Prelude---- |--- 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---- |--- Encode a host, a port, a user, a password and a database into the PostgreSQL settings byte-string.-{-# 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)-      ]
library/Hasql/Session.hs view
@@ -7,9 +7,9 @@     run,      -- * Errors-    module Hasql.Private.Errors,+    module Hasql.Errors,   ) where -import Hasql.Private.Errors-import Hasql.Private.Session+import Hasql.Errors+import Hasql.Session.Core
+ library/Hasql/Session/Core.hs view
@@ -0,0 +1,65 @@+module Hasql.Session.Core where++import qualified Hasql.Connection.Core as Connection+import qualified Hasql.Decoders.Result as Decoders.Result+import qualified Hasql.Decoders.Results as Decoders.Results+import qualified Hasql.Encoders.All as Encoders+import qualified Hasql.Encoders.Params as Encoders.Params+import Hasql.Errors+import qualified Hasql.IO as IO+import Hasql.Prelude+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)+  deriving (Functor, Applicative, Monad, MonadError QueryError, MonadIO, MonadReader Connection.Connection)++-- |+-- Executes a bunch of commands on the provided connection.+run :: Session a -> Connection.Connection -> IO (Either QueryError a)+run (Session impl) connection =+  runExceptT+    $ runReaderT impl connection++-- |+-- Possibly a multi-statement query,+-- which however cannot be parameterized or prepared,+-- 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+  where+    decoder =+      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 (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+  where+    inputReps =+      let Encoders.Params.Params (Op encoderOp) = paramsEncoder+          step (_, _, _, rendering) acc =+            rendering : acc+       in foldr step [] (encoderOp input)
+ library/Hasql/Settings.hs view
@@ -0,0 +1,39 @@+module Hasql.Settings where++import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL+import Hasql.Prelude++-- |+-- 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++-- |+-- Encode a host, a port, a user, a password and a database into the PostgreSQL settings byte-string.+{-# 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)+      ]
library/Hasql/Statement.hs view
@@ -13,9 +13,9 @@ where  import qualified Hasql.Decoders as Decoders+import qualified Hasql.Decoders.All as Decoders import qualified Hasql.Encoders as Encoders-import qualified Hasql.Private.Decoders as Decoders-import Hasql.Private.Prelude+import Hasql.Prelude  -- | -- Specification of a strictly single-statement query, which can be parameterized and prepared.