summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNikitaVolkov <>2017-10-12 12:04:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-10-12 12:04:00 (GMT)
commit15bd9e79f17313771d82d2ba5fa80ae582c9a865 (patch)
tree04994789d7e3e2e082b79d053bfec4055fa6c36d
parent0a0822a6234ec25928df537e56401deba85a05e8 (diff)
version 11
-rw-r--r--benchmarks/Main.hs146
-rw-r--r--hasql.cabal169
-rw-r--r--library/Hasql/Batch.hs9
-rw-r--r--library/Hasql/Connection.hs73
-rw-r--r--library/Hasql/Core/Batch.hs53
-rw-r--r--library/Hasql/Core/DecodePrimitive.hs59
-rw-r--r--library/Hasql/Core/DecodeResult.hs103
-rw-r--r--library/Hasql/Core/DecodeRow.hs19
-rw-r--r--library/Hasql/Core/Dispatcher.hs72
-rw-r--r--library/Hasql/Core/EncodeArray.hs20
-rw-r--r--library/Hasql/Core/EncodeParam.hs34
-rw-r--r--library/Hasql/Core/EncodeParams.hs65
-rw-r--r--library/Hasql/Core/EncodePrimitive.hs62
-rw-r--r--library/Hasql/Core/InterpretResponses.hs225
-rw-r--r--library/Hasql/Core/Loops/Interpreter.hs45
-rw-r--r--library/Hasql/Core/Loops/Receiver.hs33
-rw-r--r--library/Hasql/Core/Loops/Sender.hs16
-rw-r--r--library/Hasql/Core/Loops/Serializer.hs50
-rw-r--r--library/Hasql/Core/MessageTypeNames.hs32
-rw-r--r--library/Hasql/Core/MessageTypePredicates.hs28
-rw-r--r--library/Hasql/Core/Model.hs69
-rw-r--r--library/Hasql/Core/NoticeFieldTypes.hs22
-rw-r--r--library/Hasql/Core/OID/Array.hs73
-rw-r--r--library/Hasql/Core/OID/Primitive.hs74
-rw-r--r--library/Hasql/Core/ParseDataRow.hs38
-rw-r--r--library/Hasql/Core/PreparedStatementRegistry.hs49
-rw-r--r--library/Hasql/Core/Protocol/Decoding.hs207
-rw-r--r--library/Hasql/Core/Protocol/Encoding.hs210
-rw-r--r--library/Hasql/Core/Protocol/Model.hs211
-rw-r--r--library/Hasql/Core/Request.hs96
-rw-r--r--library/Hasql/Core/Scanner.hs193
-rw-r--r--library/Hasql/Core/Session.hs13
-rw-r--r--library/Hasql/Core/Socket.hs96
-rw-r--r--library/Hasql/Core/Statement.hs38
-rw-r--r--library/Hasql/Core/UnauthenticatedSession.hs44
-rw-r--r--library/Hasql/DecodePrimitive.hs12
-rw-r--r--library/Hasql/DecodeResult.hs18
-rw-r--r--library/Hasql/DecodeRow.hs10
-rw-r--r--library/Hasql/Decoders.hs713
-rw-r--r--library/Hasql/EncodeParam.hs10
-rw-r--r--library/Hasql/EncodeParams.hs9
-rw-r--r--library/Hasql/EncodePrimitive.hs17
-rw-r--r--library/Hasql/Encoders.hs560
-rw-r--r--library/Hasql/Prelude.hs207
-rw-r--r--library/Hasql/Private/Commands.hs33
-rw-r--r--library/Hasql/Private/Connection.hs52
-rw-r--r--library/Hasql/Private/Decoders/Array.hs30
-rw-r--r--library/Hasql/Private/Decoders/Composite.hs25
-rw-r--r--library/Hasql/Private/Decoders/Result.hs232
-rw-r--r--library/Hasql/Private/Decoders/Results.hs91
-rw-r--r--library/Hasql/Private/Decoders/Row.hs65
-rw-r--r--library/Hasql/Private/Decoders/Value.hs27
-rw-r--r--library/Hasql/Private/Encoders/Array.hs30
-rw-r--r--library/Hasql/Private/Encoders/Params.hs51
-rw-r--r--library/Hasql/Private/Encoders/Value.hs26
-rw-r--r--library/Hasql/Private/IO.hs159
-rw-r--r--library/Hasql/Private/PTI.hs94
-rw-r--r--library/Hasql/Private/Prelude.hs130
-rw-r--r--library/Hasql/Private/PreparedStatementRegistry.hs56
-rw-r--r--library/Hasql/Private/Query.hs61
-rw-r--r--library/Hasql/Private/Session.hs117
-rw-r--r--library/Hasql/Private/Settings.hs39
-rw-r--r--library/Hasql/Query.hs57
-rw-r--r--library/Hasql/Session.hs12
-rw-r--r--library/Hasql/Statement.hs9
-rw-r--r--profiling/Main.hs115
-rw-r--r--tasty/Main.hs417
-rw-r--r--tasty/Main/Connection.hs28
-rw-r--r--tasty/Main/DSL.hs47
-rw-r--r--tasty/Main/Prelude.hs14
-rw-r--r--tasty/Main/Queries.hs36
-rw-r--r--tests/Main.hs80
-rw-r--r--threads-test/Main.hs45
-rw-r--r--threads-test/Main/Queries.hs20
74 files changed, 3508 insertions, 2992 deletions
diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs
index dbefd6e..0fd3d10 100644
--- a/benchmarks/Main.hs
+++ b/benchmarks/Main.hs
@@ -5,97 +5,103 @@ import Bug
import Criterion
import Criterion.Main
import qualified Hasql.Connection as A
-import qualified Hasql.Batch as J
-import qualified Hasql.Session as F
-import qualified Hasql.Statement as G
-import qualified Hasql.DecodeResult as B
-import qualified Hasql.DecodeRow as C
-import qualified Hasql.DecodePrimitive as D
-import qualified Data.Vector as H
-import qualified Control.Foldl as I
+import qualified Hasql.Session as B
+import qualified Hasql.Query as C
+import qualified Hasql.Decoders as D
+import qualified Hasql.Encoders as E
+import qualified Data.Vector as F
main =
do
- connection <- connect
- let
- sessionBench :: NFData a => String -> F.Session a -> Benchmark
- sessionBench name session =
- bench name (nfIO (runSession session))
- where
- runSession session =
- do
- Right result <- A.session connection session
- return result
- in
- defaultMain
- [
- sessionBench "singleLargeResultInVector" singleLargeResultInVectorSession,
- sessionBench "singleLargeResultInRevList" singleLargeResultInRevListSession,
- sessionBench "manyLargeResultsInVector" manyLargeResultsInVectorSession,
- sessionBench "manyLargeResultsInVectorInBatch" manyLargeResultsInVectorInBatchSession,
- sessionBench "manySmallResults" manySmallResultsSession,
- sessionBench "manySmallResultsInBatch" manySmallResultsInBatchSession
- ]
-
-connect :: IO A.Connection
-connect =
- do
- openingResult <- A.open (A.TCPConnectionSettings "localhost" 5432) "postgres" "" Nothing handleErrorOrNotification
- case openingResult of
- Left error -> fail (showString "Can't connect: " (show error))
- Right connection -> return connection
+ Right connection <- acquireConnection
+ useConnection connection
where
- handleErrorOrNotification x =
- putStrLn ("Async event: " <> show x)
+ acquireConnection =
+ A.acquire ""
+ useConnection connection =
+ defaultMain
+ [
+ sessionBench "largeResultInVector" sessionWithSingleLargeResultInVector
+ ,
+ sessionBench "largeResultInList" sessionWithSingleLargeResultInList
+ ,
+ sessionBench "manyLargeResults" sessionWithManyLargeResults
+ ,
+ sessionBench "manySmallResults" sessionWithManySmallResults
+ ]
+ where
+ sessionBench :: NFData a => String -> B.Session a -> Benchmark
+ sessionBench name session =
+ bench name (nfIO (fmap (either ($bug "") id) (B.run session connection)))
+
-- * Sessions
-------------------------
-singleLargeResultInVectorSession :: F.Session (Vector (Int64, Int64))
-singleLargeResultInVectorSession =
- F.batch (manyRowsBatch B.vector)
+sessionWithManySmallParameters :: Vector (Int64, Int64) -> B.Session ()
+sessionWithManySmallParameters =
+ $(todo "sessionWithManySmallParameters")
-singleLargeResultInRevListSession :: F.Session [(Int64, Int64)]
-singleLargeResultInRevListSession =
- F.batch (manyRowsBatch B.revList)
+sessionWithSingleLargeResultInVector :: B.Session (Vector (Int64, Int64))
+sessionWithSingleLargeResultInVector =
+ B.query () queryWithManyRowsInVector
-manyLargeResultsInVectorSession :: F.Session [Vector (Int64, Int64)]
-manyLargeResultsInVectorSession =
- replicateM 1000 (F.batch (manyRowsBatch B.vector))
+sessionWithManyLargeResults :: B.Session [Vector (Int64, Int64)]
+sessionWithManyLargeResults =
+ replicateM 1000 (B.query () queryWithManyRowsInVector)
-manyLargeResultsInVectorInBatchSession :: F.Session [Vector (Int64, Int64)]
-manyLargeResultsInVectorInBatchSession =
- F.batch (replicateM 1000 (manyRowsBatch B.vector))
+sessionWithSingleLargeResultInList :: B.Session (List (Int64, Int64))
+sessionWithSingleLargeResultInList =
+ B.query () queryWithManyRowsInList
-manySmallResultsSession :: F.Session [(Int64, Int64)]
-manySmallResultsSession =
- replicateM 1000 (F.batch singleRowBatch)
+sessionWithManySmallResults :: B.Session [(Int64, Int64)]
+sessionWithManySmallResults =
+ replicateM 1000 (B.query () queryWithSingleRow)
-manySmallResultsInBatchSession :: F.Session [(Int64, Int64)]
-manySmallResultsInBatchSession =
- F.batch (replicateM 1000 singleRowBatch)
--- * Queries
+-- * Statements
-------------------------
-singleRowBatch :: J.Batch (Int64, Int64)
-singleRowBatch =
- J.statement (G.prepared "select 1, 2" conquer decode) ()
+queryWithManyParameters :: C.Query (Vector (Int64, Int64)) ()
+queryWithManyParameters =
+ $(todo "statementWithManyParameters")
+
+queryWithSingleRow :: C.Query () (Int64, Int64)
+queryWithSingleRow =
+ C.statement template encoder decoder True
where
- decode =
- B.head ((,) <$> C.primitive D.int8 <*> C.primitive D.int8)
+ template =
+ "SELECT 1, 2"
+ encoder =
+ conquer
+ decoder =
+ D.singleRow row
+ where
+ row =
+ tuple <$> D.value D.int8 <*> D.value D.int8
+ where
+ tuple !a !b =
+ (a, b)
-{-# INLINE manyRowsBatch #-}
-manyRowsBatch :: (C.DecodeRow (Int64, Int64) -> B.DecodeResult result) -> J.Batch result
-manyRowsBatch decodeResult =
- J.statement (G.prepared template mempty decode) ()
+queryWithManyRows :: (D.Row (Int64, Int64) -> D.Result result) -> C.Query () result
+queryWithManyRows decoder =
+ C.statement template encoder (decoder rowDecoder) True
where
template =
"SELECT generate_series(0,1000) as a, generate_series(1000,2000) as b"
- decode =
- decodeResult $
- tuple <$> C.primitive D.int8 <*> C.primitive D.int8
- where
+ encoder =
+ conquer
+ rowDecoder =
+ tuple <$> D.value D.int8 <*> D.value D.int8
+ where
tuple !a !b =
(a, b)
+
+queryWithManyRowsInVector :: C.Query () (Vector (Int64, Int64))
+queryWithManyRowsInVector =
+ queryWithManyRows D.rowsVector
+
+queryWithManyRowsInList :: C.Query () (List (Int64, Int64))
+queryWithManyRowsInList =
+ queryWithManyRows D.rowsList
diff --git a/hasql.cabal b/hasql.cabal
index 6453efa..629eda6 100644
--- a/hasql.cabal
+++ b/hasql.cabal
@@ -1,19 +1,17 @@
name:
hasql
version:
- 0.20
+ 1
category:
Hasql, Database, PostgreSQL
synopsis:
- An efficient native PostgreSQL driver
+ An efficient PostgreSQL driver and a flexible mapping API
description:
- A highly efficient PostgreSQL driver and a flexible mapping API.
- .
- This is an experimental version, which implements the binary protocol natively.
- .
This package is the root of the \"hasql\" ecosystem.
.
The API is completely disinfected from exceptions. All error-reporting is explicit and is presented using the 'Either' type.
+ .
+ The version 1 is completely backward-compatible with 0.19.
homepage:
https://github.com/nikita-volkov/hasql
bug-reports:
@@ -33,123 +31,97 @@ build-type:
cabal-version:
>=1.10
+
source-repository head
type:
git
location:
git://github.com/nikita-volkov/hasql.git
+
library
hs-source-dirs:
library
+ ghc-options:
default-extensions:
- Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples
+ Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples
default-language:
Haskell2010
+ other-modules:
+ Hasql.Private.Prelude
+ Hasql.Private.PTI
+ Hasql.Private.IO
+ Hasql.Private.Query
+ Hasql.Private.Session
+ Hasql.Private.Connection
+ Hasql.Private.PreparedStatementRegistry
+ Hasql.Private.Settings
+ Hasql.Private.Commands
+ Hasql.Private.Decoders.Array
+ Hasql.Private.Decoders.Composite
+ Hasql.Private.Decoders.Value
+ Hasql.Private.Decoders.Row
+ Hasql.Private.Decoders.Result
+ Hasql.Private.Decoders.Results
+ Hasql.Private.Encoders.Array
+ Hasql.Private.Encoders.Value
+ Hasql.Private.Encoders.Params
exposed-modules:
+ Hasql.Decoders
+ Hasql.Encoders
Hasql.Connection
- Hasql.Statement
- Hasql.EncodeParams
- Hasql.EncodeParam
- Hasql.EncodePrimitive
- Hasql.DecodeResult
- Hasql.DecodeRow
- Hasql.DecodePrimitive
- Hasql.Batch
+ Hasql.Query
Hasql.Session
- other-modules:
- Hasql.Prelude
- Hasql.Core.Statement
- Hasql.Core.Batch
- Hasql.Core.Session
- Hasql.Core.Model
- Hasql.Core.EncodeParams
- Hasql.Core.EncodeParam
- Hasql.Core.EncodePrimitive
- Hasql.Core.EncodeArray
- Hasql.Core.DecodeResult
- Hasql.Core.DecodeRow
- Hasql.Core.DecodePrimitive
- Hasql.Core.InterpretResponses
- Hasql.Core.UnauthenticatedSession
- Hasql.Core.Request
- Hasql.Core.Dispatcher
- Hasql.Core.ParseDataRow
- Hasql.Core.MessageTypePredicates
- Hasql.Core.NoticeFieldTypes
- Hasql.Core.MessageTypeNames
- Hasql.Core.Scanner
- Hasql.Core.Loops.Serializer
- Hasql.Core.Loops.Receiver
- Hasql.Core.Loops.Sender
- Hasql.Core.Loops.Interpreter
- Hasql.Core.Socket
- Hasql.Core.OID.Array
- Hasql.Core.OID.Primitive
- Hasql.Core.PreparedStatementRegistry
- Hasql.Core.Protocol.Decoding
- Hasql.Core.Protocol.Encoding
- Hasql.Core.Protocol.Model
build-depends:
- -- concurrency:
- stm >= 2.4 && < 3,
- slave-thread == 1.*,
- -- networking:
- network == 2.*,
- -- template-haskell:
- template-haskell == 2.*,
-- parsing:
- scanner == 0.2.*,
- binary-parser >= 0.5.5 && < 0.6,
attoparsec >= 0.10 && < 0.14,
-- database:
- postgresql-binary == 0.12.*,
+ postgresql-binary >= 0.12.1 && < 0.13,
+ postgresql-libpq == 0.9.*,
+ -- builders:
+ bytestring-strict-builder >= 0.4 && < 0.5,
-- data:
- bytestring-strict-builder >= 0.4.5 && < 0.5,
- vector-builder == 0.3.*,
- deque == 0.2.*,
- cryptonite == 0.22.*,
- persistent-vector == 0.1.*,
dlist >= 0.7 && < 0.9,
- aeson >= 0.7 && < 2,
vector >= 0.10 && < 0.13,
+ hashtables >= 1.1 && < 2,
text >= 1 && < 2,
bytestring >= 0.10 && < 0.11,
hashable >= 1.2 && < 1.3,
- containers == 0.5.*,
- unordered-containers == 0.2.*,
- time == 1.*,
-- control:
- free >= 4.12.4 && < 5,
- managed == 1.*,
- foldl >= 1.3 && < 2,
semigroups >= 0.18 && < 0.20,
+ data-default-class >= 0.0.1 && < 0.2,
profunctors >= 5.1 && < 6,
+ contravariant-extras == 0.3.*,
contravariant >= 1.3 && < 2,
+ either >= 4.4.1 && < 5,
mtl >= 2 && < 3,
transformers >= 0.3 && < 0.6,
-- errors:
- bug == 1.*,
+ loch-th == 0.2.*,
+ placeholders == 0.1.*,
-- general:
base-prelude >= 0.1.19 && < 2,
- base >= 4.7 && < 5
+ base >= 4.6 && < 5
+
-test-suite tests
+test-suite tasty
type:
exitcode-stdio-1.0
hs-source-dirs:
- tests
+ tasty
main-is:
Main.hs
- ghc-options:
- -O2
- -threaded
- "-with-rtsopts=-N"
+ other-modules:
+ Main.DSL
+ Main.Connection
+ Main.Queries
+ Main.Prelude
default-extensions:
Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples
default-language:
Haskell2010
build-depends:
+ -- database:
hasql,
-- testing:
tasty == 0.11.*,
@@ -158,23 +130,49 @@ test-suite tests
tasty-hunit == 0.9.*,
quickcheck-instances >= 0.3.11 && < 0.4,
QuickCheck >= 2.8.1 && < 2.10,
+ -- general:
+ data-default-class,
--
- foldl,
- bug == 1.*,
- rerebase == 1.*
+ rerebase < 2
-benchmark benchmarks
+
+test-suite threads-test
type:
exitcode-stdio-1.0
hs-source-dirs:
+ threads-test
+ main-is:
+ Main.hs
+ other-modules:
+ Main.Queries
+ ghc-options:
+ -O2
+ -threaded
+ "-with-rtsopts=-N"
+ default-extensions:
+ Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples
+ default-language:
+ Haskell2010
+ build-depends:
+ -- database:
+ hasql,
+ --
+ rebase
+
+
+benchmark benchmarks
+ type:
+ exitcode-stdio-1.0
+ hs-source-dirs:
benchmarks
main-is:
Main.hs
ghc-options:
-O2
-threaded
- -rtsopts
"-with-rtsopts=-N"
+ -rtsopts
+ -funbox-strict-fields
default-extensions:
Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples
default-language:
@@ -182,12 +180,12 @@ benchmark benchmarks
build-depends:
hasql,
-- benchmarking:
- criterion >= 1.0 && < 2,
+ criterion >= 1.1 && < 2,
-- general:
- foldl,
bug == 1.*,
rerebase < 2
+
test-suite profiling
type:
exitcode-stdio-1.0
@@ -205,6 +203,5 @@ test-suite profiling
Haskell2010
build-depends:
hasql,
- foldl,
bug == 1.*,
rerebase == 1.*
diff --git a/library/Hasql/Batch.hs b/library/Hasql/Batch.hs
deleted file mode 100644
index f4cb9ec..0000000
--- a/library/Hasql/Batch.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module Hasql.Batch
-(
- Batch,
- statement,
-)
-where
-
-import Hasql.Core.Batch
-
diff --git a/library/Hasql/Connection.hs b/library/Hasql/Connection.hs
index 11f2ee8..1e70b6a 100644
--- a/library/Hasql/Connection.hs
+++ b/library/Hasql/Connection.hs
@@ -1,69 +1,16 @@
+-- |
+-- This module provides a low-level effectful API dealing with the connections to the database.
module Hasql.Connection
(
Connection,
- B.ConnectionSettings(..),
- Error(..),
- Notification(..),
- open,
- session,
- batch,
- close,
+ ConnectionError(..),
+ acquire,
+ release,
+ Settings,
+ settings,
+ withLibPQConnection
)
where
-import Hasql.Prelude hiding (interact)
-import Hasql.Core.Model
-import qualified Hasql.Core.Dispatcher as A
-import qualified Hasql.Core.Socket as B
-import qualified Hasql.Core.Request as C
-import qualified Hasql.Core.PreparedStatementRegistry as D
-import qualified Hasql.Core.Batch as E
-import qualified Hasql.Core.Session as F
-import qualified Hasql.Core.UnauthenticatedSession as G
-
-
-data Connection =
- {-
- We use 'MVar' over registry insteadOf 'atomicModifyIORef' to protect
- from race conditions, when one thread might initiate a query over a prepared statement,
- which hasn't yet been committed by another thread, when that other thread has already updated
- the registry.
- -}
- Connection !B.Socket !A.Dispatcher !(MVar D.Registry) !Bool
-
-open :: B.ConnectionSettings -> ByteString -> ByteString -> Maybe ByteString -> (Notification -> IO ()) -> IO (Either Error Connection)
-open transportSettings username password databaseMaybe sendNotification =
- do
- connectionResult <- B.connect transportSettings
- case connectionResult of
- Left message -> return (Left (TransportError message))
- Right socket -> do
- dispatcher <- A.start socket sendNotification
- handshakeResult <- A.interact dispatcher (G.handshake username password databaseMaybe [])
- case handshakeResult of
- Left error -> return (Left error)
- Right errorOrIdt -> case errorOrIdt of
- Left error -> return (Left (TransportError error))
- Right idt -> do
- psrVar <- newMVar D.nil
- return (Right (Connection socket dispatcher psrVar idt))
-
-session :: Connection -> F.Session result -> IO (Either Error result)
-session connection (F.Session free) =
- runExceptT (iterM (\x -> join (ExceptT (batch connection x))) free)
-
-batch :: Connection -> E.Batch result -> IO (Either Error result)
-batch (Connection _ dispatcher psrVar idt) (E.Batch batchFn) =
- do
- psr <- takeMVar psrVar
- case batchFn idt psr of
- (request, newPsr) -> do
- result <- A.performRequest dispatcher (request <* C.sync)
- putMVar psrVar $ case result of
- Left (BackendError _ _) -> psr
- _ -> newPsr
- return result
-
-close :: Connection -> IO ()
-close (Connection socket dispatcher _ _) =
- A.stop dispatcher >> B.close socket
+import Hasql.Private.Connection
+import Hasql.Private.Settings
diff --git a/library/Hasql/Core/Batch.hs b/library/Hasql/Core/Batch.hs
deleted file mode 100644
index 7aefa75..0000000
--- a/library/Hasql/Core/Batch.hs
+++ /dev/null
@@ -1,53 +0,0 @@
-module Hasql.Core.Batch where
-
-import Hasql.Prelude
-import Hasql.Core.Model
-import qualified Hasql.Core.Statement as A
-import qualified Hasql.Core.Request as C
-import qualified Hasql.Core.PreparedStatementRegistry as D
-import qualified ByteString.StrictBuilder as E
-import qualified Hasql.Core.DecodeResult as F
-import qualified VectorBuilder.Vector as O
-import qualified Data.Vector as G
-
-
-newtype Batch result =
- Batch (Bool -> D.Registry -> (C.Request result, D.Registry))
-
-deriving instance Functor Batch
-
-instance Applicative Batch where
- {-# INLINE pure #-}
- pure x =
- Batch (\_ psr -> (pure x, psr))
- {-# INLINABLE (<*>) #-}
- (<*>) (Batch left) (Batch right) =
- Batch (\idt psr -> case left idt psr of
- (leftRequest, leftPsr) -> case right idt leftPsr of
- (rightRequest, rightPsr) -> (leftRequest <*> rightRequest, rightPsr))
-
-statement :: A.Statement params result -> params -> Batch result
-statement (A.Statement template paramOIDs paramBytesBuilder1 paramBytesBuilder2 interpretResponses1 interpretResponses2 prepared) params =
- Batch $ \idt psr ->
- if prepared
- then case D.lookupOrRegister template paramOIDs psr of
- (newOrOldName, newPsr) ->
- let
- request =
- case newOrOldName of
- Left name ->
- C.unparsedStatement name template paramOIDs
- (bool paramBytesBuilder2 paramBytesBuilder1 idt params)
- (bool interpretResponses2 interpretResponses1 idt)
- Right name ->
- C.parsedStatement name template (G.length paramOIDs)
- (bool paramBytesBuilder2 paramBytesBuilder1 idt params)
- (bool interpretResponses2 interpretResponses1 idt)
- in (request, newPsr)
- else
- let
- request =
- C.unparsedStatement "" template paramOIDs
- (bool paramBytesBuilder2 paramBytesBuilder1 idt params)
- (bool interpretResponses2 interpretResponses1 idt)
- in (request, psr)
diff --git a/library/Hasql/Core/DecodePrimitive.hs b/library/Hasql/Core/DecodePrimitive.hs
deleted file mode 100644
index 1712b17..0000000
--- a/library/Hasql/Core/DecodePrimitive.hs
+++ /dev/null
@@ -1,59 +0,0 @@
-module Hasql.Core.DecodePrimitive where
-
-import Hasql.Prelude hiding (bool)
-import Hasql.Core.Model
-import qualified BinaryParser as A
-import qualified PostgreSQL.Binary.Decoding as B
-
-
-newtype DecodePrimitive primitive =
- DecodePrimitive (ReaderT Bool A.BinaryParser primitive)
- deriving (Functor)
-
-
--- * Helpers
--------------------------
-
-{-# INLINE nonDateTime #-}
-nonDateTime :: A.BinaryParser primitive -> DecodePrimitive primitive
-nonDateTime parser =
- DecodePrimitive (ReaderT (const parser))
-
-{-# INLINE dateTime #-}
-dateTime :: A.BinaryParser primitive -> A.BinaryParser primitive -> DecodePrimitive primitive
-dateTime intParser floatParser =
- DecodePrimitive (ReaderT (\case False -> floatParser; True -> intParser))
-
--- * Numbers
--------------------------
-
-{-# INLINE bool #-}
-bool :: DecodePrimitive Bool
-bool =
- nonDateTime B.bool
-
-{-# INLINE int8 #-}
-int8 :: DecodePrimitive Int64
-int8 =
- nonDateTime B.int
-
--- * Blobs
--------------------------
-
-{-# INLINE text #-}
-text :: DecodePrimitive Text
-text =
- nonDateTime B.text_strict
-
-{-# INLINE bytea #-}
-bytea :: DecodePrimitive ByteString
-bytea =
- nonDateTime B.bytea_strict
-
--- * Time
--------------------------
-
-{-# INLINE timestamptz #-}
-timestamptz :: DecodePrimitive UTCTime
-timestamptz =
- dateTime B.timestamptz_int B.timestamptz_float
diff --git a/library/Hasql/Core/DecodeResult.hs b/library/Hasql/Core/DecodeResult.hs
deleted file mode 100644
index a01f475..0000000
--- a/library/Hasql/Core/DecodeResult.hs
+++ /dev/null
@@ -1,103 +0,0 @@
-module Hasql.Core.DecodeResult where
-
-import Hasql.Prelude
-import Hasql.Core.Model
-import qualified Hasql.Core.InterpretResponses as A
-import qualified Hasql.Core.DecodeRow as B
-import qualified Control.Foldl as C
-import qualified Data.HashMap.Strict as L
-
-
-newtype DecodeResult result =
- DecodeResult (ReaderT Bool A.InterpretResponses result)
- deriving (Functor)
-
-{-|
-Ignore the result.
--}
-{-# INLINE ignore #-}
-ignore :: DecodeResult ()
-ignore =
- DecodeResult (ReaderT (const (pure ())))
-
-{-|
-The amount of rows affected by the statement.
-All statements produce this result.
--}
-{-# INLINE length #-}
-length :: DecodeResult Int
-length =
- DecodeResult (ReaderT (const (A.rowsAffected)))
-
-{-|
-First row of a non-empty result.
-Raises a connection error if there's no rows.
--}
-{-# INLINE head #-}
-head :: B.DecodeRow row -> DecodeResult row
-head (B.DecodeRow (ReaderT parseDataRow)) =
- DecodeResult (ReaderT (\idt -> A.singleRow (parseDataRow idt)))
-
-{-|
-First row of a possibly empty result set.
--}
-{-# INLINE headIfExists #-}
-headIfExists :: B.DecodeRow row -> DecodeResult (Maybe row)
-headIfExists =
- fmap fst . foldRows C.head
-
-{-|
-Vector of rows.
--}
-{-# INLINE vector #-}
-vector :: B.DecodeRow row -> DecodeResult (Vector row)
-vector =
- fmap fst . foldRows C.vector
-
-{-|
-List of rows. Slower than 'revList'.
--}
-{-# INLINE list #-}
-list :: B.DecodeRow row -> DecodeResult [row]
-list =
- fmap fst . foldRows C.list
-
-{-|
-List of rows in a reverse order. Faster than 'list'.
--}
-{-# INLINE revList #-}
-revList :: B.DecodeRow row -> DecodeResult [row]
-revList =
- fmap fst . foldRows C.revList
-
-{-|
-Rows folded into a map.
--}
-{-# INLINE hashMap #-}
-hashMap :: (Eq key, Hashable key) => B.DecodeRow (key, value) -> DecodeResult (HashMap key value)
-hashMap decodeRow =
- fmap fst (foldRows (C.Fold (\m (k, v) -> L.insert k v m) L.empty id) decodeRow)
-
-{-|
-Essentially, a specification of Map/Reduce over all the rows of the result set.
-Can be used to produce all kinds of containers or to implement aggregation algorithms on the client side.
-
-Besides the result of folding it returns the amount of affected rows,
-since it's provided by the database either way.
--}
-{-# INLINE foldRows #-}
-foldRows :: Fold row result -> B.DecodeRow row -> DecodeResult (result, Int)
-foldRows fold =
- foldMRows (C.generalize fold)
-
-{-|
-Essentially, a specification of Map/Reduce over all the rows of the result set.
-Can be used to produce all kinds of containers or to implement aggregation algorithms on the client side.
-
-Besides the result of folding it returns the amount of affected rows,
-since it's provided by the database either way.
--}
-{-# INLINE foldMRows #-}
-foldMRows :: FoldM IO row result -> B.DecodeRow row -> DecodeResult (result, Int)
-foldMRows fold (B.DecodeRow (ReaderT parseDataRow)) =
- DecodeResult (ReaderT (\idt -> A.foldRows fold (parseDataRow idt)))
diff --git a/library/Hasql/Core/DecodeRow.hs b/library/Hasql/Core/DecodeRow.hs
deleted file mode 100644
index 60f29e3..0000000
--- a/library/Hasql/Core/DecodeRow.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module Hasql.Core.DecodeRow where
-
-import Hasql.Prelude
-import Hasql.Core.Model
-import qualified Hasql.Core.ParseDataRow as A
-import qualified Hasql.Core.DecodePrimitive as B
-
-
-newtype DecodeRow row =
- DecodeRow (ReaderT Bool A.ParseDataRow row)
- deriving (Functor, Applicative)
-
-primitive :: B.DecodePrimitive column -> DecodeRow column
-primitive (B.DecodePrimitive (ReaderT parser)) =
- DecodeRow (ReaderT (A.column . parser))
-
-nullablePrimitive :: B.DecodePrimitive column -> DecodeRow (Maybe column)
-nullablePrimitive (B.DecodePrimitive (ReaderT parser)) =
- DecodeRow (ReaderT (A.nullableColumn . parser))
diff --git a/library/Hasql/Core/Dispatcher.hs b/library/Hasql/Core/Dispatcher.hs
deleted file mode 100644
index 1268dc8..0000000
--- a/library/Hasql/Core/Dispatcher.hs
+++ /dev/null
@@ -1,72 +0,0 @@
-module Hasql.Core.Dispatcher where
-
-import Hasql.Prelude
-import Hasql.Core.Model
-import qualified Hasql.Core.Socket as A
-import qualified ByteString.StrictBuilder as B
-import qualified BinaryParser as D
-import qualified Hasql.Core.Request as C
-import qualified Hasql.Core.UnauthenticatedSession as G
-import qualified Hasql.Core.Loops.Serializer as H
-import qualified Hasql.Core.Loops.Receiver as I
-import qualified Hasql.Core.Loops.Sender as J
-import qualified Hasql.Core.Loops.Interpreter as K
-
-
-data Dispatcher =
- Dispatcher
- !ThreadId !ThreadId !ThreadId !ThreadId
- !(TQueue ByteString) !(TQueue H.Message) !(TQueue Response) !(TQueue K.ResultProcessor) !(TMVar Text)
-
-start :: A.Socket -> (Notification -> IO ()) -> IO Dispatcher
-start socket sendNotification =
- do
- outgoingBytesQueue <- newTQueueIO
- serializerMessageQueue <- newTQueueIO
- responseQueue <- newTQueueIO
- resultProcessorQueue <- newTQueueIO
- transportErrorVar <- newEmptyTMVarIO
- interpreterTid <-
- forkIO (K.loop
- (atomically (readTQueue responseQueue))
- (atomically (tryReadTQueue resultProcessorQueue))
- (sendNotification))
- serializerTid <-
- forkIO (H.loop
- (atomically (readTQueue serializerMessageQueue))
- (atomically . writeTQueue outgoingBytesQueue))
- senderTid <-
- forkIO (J.loop socket
- (atomically (readTQueue outgoingBytesQueue))
- (atomically . putTMVar transportErrorVar))
- receiverTid <-
- forkIO (I.loop socket
- (atomically . writeTQueue responseQueue)
- (atomically . putTMVar transportErrorVar))
- return (Dispatcher interpreterTid serializerTid senderTid receiverTid
- outgoingBytesQueue serializerMessageQueue responseQueue resultProcessorQueue transportErrorVar)
-
-performRequest :: Dispatcher -> C.Request result -> IO (Either Error result)
-performRequest (Dispatcher _ _ _ _ _ serializerMessageQueue _ resultProcessorQueue transportErrorVar) (C.Request builder ir) =
- do
- resultVar <- newEmptyTMVarIO
- atomically $ do
- writeTQueue resultProcessorQueue (K.ResultProcessor ir (atomically . putTMVar resultVar))
- writeTQueue serializerMessageQueue (H.SerializeMessage builder)
- writeTQueue serializerMessageQueue (H.FlushMessage)
- atomically (fmap (Left . TransportError) (readTMVar transportErrorVar) <|> takeTMVar resultVar)
-
-stop :: Dispatcher -> IO ()
-stop (Dispatcher interpreterTid serializerTid senderTid receiverTid _ _ _ _ _) =
- do
- killThread interpreterTid
- killThread serializerTid
- killThread senderTid
- killThread receiverTid
-
-interact :: Dispatcher -> G.Session result -> IO (Either Error result)
-interact dispatcher (G.Session free) =
- runExceptT $ iterM interpretFreeRequest free
- where
- interpretFreeRequest request =
- join (ExceptT (performRequest dispatcher request))
diff --git a/library/Hasql/Core/EncodeArray.hs b/library/Hasql/Core/EncodeArray.hs
deleted file mode 100644
index d00c924..0000000
--- a/library/Hasql/Core/EncodeArray.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module Hasql.Core.EncodeArray where
-
-import Hasql.Prelude
-import qualified Hasql.Core.EncodePrimitive as B
-import qualified PostgreSQL.Binary.Encoding as A
-
-
-data EncodeArray array =
- EncodeArray Word32 Word32 (array -> A.Array) (array -> A.Array)
-
-primitive :: B.EncodePrimitive element -> EncodeArray element
-primitive (B.EncodePrimitive elementOID arrayOID encoder1 encoder2) =
- EncodeArray elementOID arrayOID (A.encodingArray . encoder1) (A.encodingArray . encoder2)
-
-nullablePrimitive :: B.EncodePrimitive element -> EncodeArray (Maybe element)
-nullablePrimitive (B.EncodePrimitive elementOID arrayOID encoder1 encoder2) =
- EncodeArray elementOID arrayOID (arrayEncoder encoder1) (arrayEncoder encoder2)
- where
- arrayEncoder encoder =
- maybe A.nullArray (A.encodingArray . encoder)
diff --git a/library/Hasql/Core/EncodeParam.hs b/library/Hasql/Core/EncodeParam.hs
deleted file mode 100644
index f5f0e6b..0000000
--- a/library/Hasql/Core/EncodeParam.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-module Hasql.Core.EncodeParam where
-
-import Hasql.Prelude
-import Hasql.Core.Model
-import qualified ByteString.StrictBuilder as B
-import qualified VectorBuilder.Builder as N
-import qualified PostgreSQL.Binary.Encoding as A
-import qualified Hasql.Core.EncodePrimitive as C
-
-
-data EncodeParam param =
- EncodeParam Word32 (param -> B.Builder) (param -> B.Builder)
-
-instance Contravariant EncodeParam where
- contramap mapping (EncodeParam oid idtOnEncode idtOffEncode) =
- EncodeParam oid (idtOnEncode . mapping) (idtOffEncode . mapping)
-
-primitive :: C.EncodePrimitive primitive -> EncodeParam primitive
-primitive (C.EncodePrimitive elementOID _ builder1 builder2) =
- EncodeParam elementOID builder1 builder2
-
-arrayVector :: C.EncodePrimitive primitive -> EncodeParam (Vector primitive)
-arrayVector (C.EncodePrimitive elementOID arrayOID elementEncoder1 elementEncoder2) =
- EncodeParam arrayOID (encoder elementEncoder1) (encoder elementEncoder2)
- where
- encoder elementEncoder =
- A.array_vector elementOID elementEncoder
-
-arrayVectorWithNulls :: C.EncodePrimitive primitive -> EncodeParam (Vector (Maybe primitive))
-arrayVectorWithNulls (C.EncodePrimitive elementOID arrayOID elementEncoder1 elementEncoder2) =
- EncodeParam arrayOID (encoder elementEncoder1) (encoder elementEncoder2)
- where
- encoder elementEncoder =
- A.nullableArray_vector elementOID elementEncoder
diff --git a/library/Hasql/Core/EncodeParams.hs b/library/Hasql/Core/EncodeParams.hs
deleted file mode 100644
index 305560d..0000000
--- a/library/Hasql/Core/EncodeParams.hs
+++ /dev/null
@@ -1,65 +0,0 @@
-module Hasql.Core.EncodeParams where
-
-import Hasql.Prelude
-import Hasql.Core.Model
-import qualified ByteString.StrictBuilder as B
-import qualified VectorBuilder.Builder as N
-import qualified Hasql.Core.EncodeParam as A
-import qualified Hasql.Core.Protocol.Encoding as C
-
-
-data EncodeParams input =
- EncodeParams (N.Builder Word32) (input -> B.Builder) (input -> B.Builder)
-
-instance Semigroup (EncodeParams input) where
- {-# INLINE (<>) #-}
- (<>) (EncodeParams leftOids leftBuilder1 leftBuilder2) (EncodeParams rightOids rightBuilder1 rightBuilder2) =
- EncodeParams oids builder1 builder2
- where
- oids =
- leftOids <> rightOids
- builder1 =
- leftBuilder1 <> rightBuilder1
- builder2 =
- leftBuilder2 <> rightBuilder2
-
-instance Monoid (EncodeParams input) where
- {-# INLINE mempty #-}
- mempty =
- EncodeParams mempty mempty mempty
- {-# INLINE mappend #-}
- mappend =
- (<>)
-
-instance Contravariant EncodeParams where
- {-# INLINE contramap #-}
- contramap fn (EncodeParams oids builder1 builder2) =
- EncodeParams oids (builder1 . fn) (builder2 . fn)
-
-instance Divisible EncodeParams where
- {-# INLINE conquer #-}
- conquer =
- mempty
- {-# INLINABLE divide #-}
- divide fn (EncodeParams leftOids leftBuilder1 leftBuilder2) (EncodeParams rightOids rightBuilder1 rightBuilder2) =
- EncodeParams oids builder1 builder2
- where
- oids =
- leftOids <> rightOids
- builder1 =
- mergedBuilder leftBuilder1 rightBuilder1
- builder2 =
- mergedBuilder leftBuilder2 rightBuilder2
- mergedBuilder leftBuilder rightBuilder params =
- case fn params of
- (leftParams, rightParams) ->
- leftBuilder leftParams <>
- rightBuilder rightParams
-
-param :: A.EncodeParam param -> EncodeParams param
-param (A.EncodeParam oid idtOnEncode idtOffEncode) =
- EncodeParams (N.singleton oid) (C.sizedValue . idtOnEncode) (C.sizedValue . idtOffEncode)
-
-nullableParam :: A.EncodeParam param -> EncodeParams (Maybe param)
-nullableParam (A.EncodeParam oid idtOnEncode idtOffEncode) =
- EncodeParams (N.singleton oid) (C.nullableSizedValue . fmap idtOnEncode) (C.nullableSizedValue . fmap idtOffEncode)
diff --git a/library/Hasql/Core/EncodePrimitive.hs b/library/Hasql/Core/EncodePrimitive.hs
deleted file mode 100644
index 47c9e01..0000000
--- a/library/Hasql/Core/EncodePrimitive.hs
+++ /dev/null
@@ -1,62 +0,0 @@
-module Hasql.Core.EncodePrimitive where
-
-import Hasql.Prelude
-import Hasql.Core.Model
-import qualified ByteString.StrictBuilder as B
-import qualified PostgreSQL.Binary.Encoding as A
-import qualified PostgreSQL.Binary.Data as F
-import qualified Hasql.Core.OID.Primitive as D
-import qualified Hasql.Core.OID.Array as E
-
-
-data EncodePrimitive primitive =
- EncodePrimitive Word32 Word32 (primitive -> B.Builder) (primitive -> B.Builder)
-
-instance Contravariant EncodePrimitive where
- {-# INLINE contramap #-}
- contramap fn (EncodePrimitive primitiveOID arrayOID builder1 builder2) =
- EncodePrimitive primitiveOID arrayOID (builder1 . fn) (builder2 . fn)
-
-int2 :: EncodePrimitive Int16
-int2 =
- EncodePrimitive D.int2 E.int2 A.int2_int16 A.int2_int16
-
-int4 :: EncodePrimitive Int32
-int4 =
- EncodePrimitive D.int4 E.int4 A.int4_int32 A.int4_int32
-
-int8 :: EncodePrimitive Int64
-int8 =
- EncodePrimitive D.int8 E.int8 A.int8_int64 A.int8_int64
-
-text :: EncodePrimitive Text
-text =
- EncodePrimitive D.text E.text A.text_strict A.text_strict
-
-
--- ** Time
--------------------------
-
-date :: EncodePrimitive F.Day
-date =
- EncodePrimitive D.date E.date A.date A.date
-
-time :: EncodePrimitive F.TimeOfDay
-time =
- EncodePrimitive D.time E.time A.time_int A.time_float
-
-timetz :: EncodePrimitive (F.TimeOfDay, F.TimeZone)
-timetz =
- EncodePrimitive D.timetz E.timetz A.timetz_int A.timetz_float
-
-timestamp :: EncodePrimitive F.LocalTime
-timestamp =
- EncodePrimitive D.timestamp E.timestamp A.timestamp_int A.timestamp_float
-
-timestamptz :: EncodePrimitive F.UTCTime
-timestamptz =
- EncodePrimitive D.timestamptz E.timestamptz A.timestamptz_int A.timestamptz_float
-
-interval :: EncodePrimitive F.DiffTime
-interval =
- EncodePrimitive D.interval E.interval A.interval_int A.interval_float
diff --git a/library/Hasql/Core/InterpretResponses.hs b/library/Hasql/Core/InterpretResponses.hs
deleted file mode 100644
index 6e4a7e1..0000000
--- a/library/Hasql/Core/InterpretResponses.hs
+++ /dev/null
@@ -1,225 +0,0 @@
-module Hasql.Core.InterpretResponses where
-
-import Hasql.Prelude
-import Hasql.Core.Model
-import qualified Hasql.Core.MessageTypePredicates as G
-import qualified Hasql.Core.MessageTypeNames as H
-import qualified Hasql.Core.ParseDataRow as A
-import qualified Data.Vector as B
-
-
-newtype InterpretResponses result =
- InterpretResponses (IO Response -> (Response -> IO ()) -> IO (Either Error result))
-
-instance Functor InterpretResponses where
- fmap mapping (InterpretResponses io) =
- InterpretResponses (\a b -> (fmap . fmap) mapping (io a b))
-
-instance Applicative InterpretResponses where
- pure x =
- InterpretResponses (\_ _ -> pure (Right x))
- (<*>) (InterpretResponses leftIO) (InterpretResponses rightIO) =
- InterpretResponses $ \fetchResponse discardResponse -> do
- leftEither <- leftIO fetchResponse discardResponse
- case leftEither of
- Left error -> return (Left error)
- Right leftResult -> do
- rightEither <- rightIO fetchResponse discardResponse
- return (fmap leftResult rightEither)
-
-instance Monad InterpretResponses where
- return = pure
- (>>=) (InterpretResponses leftIO) rightK =
- InterpretResponses $ \fetchResponse discardResponse ->
- do
- leftEither <- leftIO fetchResponse discardResponse
- case leftEither of
- Left error -> return (Left error)
- Right leftResult -> case rightK leftResult of
- InterpretResponses rightIO -> rightIO fetchResponse discardResponse
-
-
-matchResponse :: (Response -> Maybe (Either Error result)) -> InterpretResponses result
-matchResponse match =
- InterpretResponses def
- where
- def fetchResponse discardResponse =
- fetchResponse >>= processResponse
- where
- processResponse response =
- case match response of
- Just result -> return result
- Nothing -> case response of
- ErrorResponse status message -> return (Left (BackendError status message))
- _ -> do
- discardResponse response
- nextResponse <- fetchResponse
- processResponse response
-
-foldRows :: FoldM IO row result -> A.ParseDataRow row -> InterpretResponses (result, Int)
-foldRows (FoldM foldStep foldStart foldEnd) (A.ParseDataRow rowLength vectorFn) =
- InterpretResponses def
- where
- def fetchResponse discardResponse =
- do
- initialState <- foldStart
- fetchResponse >>= processResponse initialState
- where
- processResponse !state response =
- case response of
- DataRowResponse values ->
- if B.length values == rowLength
- then case vectorFn values 0 of
- Left error -> return (Left (DecodingError error))
- Right row -> do
- nextState <- foldStep state row
- nextResponse <- fetchResponse
- processResponse nextState nextResponse
- else return (Left (DecodingError (fromString
- (showString "Invalid amount of columns: "
- (shows (B.length values)
- (showString ", expecting "
- (show rowLength)))))))
- CommandCompleteResponse amount ->
- do
- result <- foldEnd state
- return (Right (result, amount))
- ErrorResponse state message ->
- return (Left (BackendError state message))
- EmptyQueryResponse ->
- do
- result <- foldEnd state
- return (Right (result, 0))
- otherResponse ->
- do
- discardResponse otherResponse
- nextResponse <- fetchResponse
- processResponse state nextResponse
-
-singleRow :: A.ParseDataRow row -> InterpretResponses row
-singleRow (A.ParseDataRow rowLength vectorFn) =
- InterpretResponses def
- where
- def fetchResponse discardResponse =
- fetchResponse >>= processResponseWithoutRow
- where
- processResponseWithoutRow response =
- case response of
- DataRowResponse values ->
- if B.length values == rowLength
- then case vectorFn values 0 of
- Left error -> return (Left (DecodingError error))
- Right row -> do
- nextResponse <- fetchResponse
- processResponseWithRow row nextResponse
- else return (Left (DecodingError (fromString
- (showString "Invalid amount of columns: "
- (shows (B.length values)
- (showString ", expecting "
- (show rowLength)))))))
- CommandCompleteResponse _ ->
- return (Left (DecodingError "Not a single row"))
- ErrorResponse state message ->
- return (Left (BackendError state message))
- EmptyQueryResponse ->
- return (Left (DecodingError "Empty query"))
- otherResponse ->
- do
- discardResponse otherResponse
- nextResponse <- fetchResponse
- processResponseWithoutRow nextResponse
- processResponseWithRow row response =
- case response of
- DataRowResponse _ ->
- do
- nextResponse <- fetchResponse
- processResponseWithRow row nextResponse
- CommandCompleteResponse _ ->
- return (Right row)
- ErrorResponse state message ->
- return (Left (BackendError state message))
- otherResponse ->
- do
- discardResponse otherResponse
- nextResponse <- fetchResponse
- processResponseWithRow row nextResponse
-
-rowsAffected :: InterpretResponses Int
-rowsAffected =
- InterpretResponses def
- where
- def fetchResponse discardResponse =
- fetchResponse >>= processResponse
- where
- processResponse =
- \case
- CommandCompleteResponse amount -> return (Right amount)
- DataRowResponse _ -> fetchResponse >>= processResponse
- ErrorResponse state message -> return (Left (BackendError state message))
- EmptyQueryResponse -> return (Right 0)
- otherResponse -> do
- discardResponse otherResponse
- nextResponse <- fetchResponse
- processResponse nextResponse
-
-authenticationStatus :: InterpretResponses AuthenticationStatus
-authenticationStatus =
- matchResponse $ \case
- AuthenticationResponse status -> Just (Right status)
- _ -> Nothing
-
-parameterStatus :: (ByteString -> ByteString -> result) -> InterpretResponses result
-parameterStatus result =
- matchResponse $ \case
- ParameterStatusResponse name value -> Just (Right (result name value))
- _ -> Nothing
-
-parameters :: InterpretResponses Bool
-parameters =
- InterpretResponses def
- where
- def fetchResponse discardResponse =
- fetchResponse >>= processResponse (Left (ProtocolError "Missing the \"integer_datetimes\" setting"))
- where
- processResponse !state =
- \case
- ParameterStatusResponse name value -> do
- nextResponse <- fetchResponse
- case name of
- "integer_datetimes" -> case value of
- "on" -> processResponse (Right True) nextResponse
- "off" -> processResponse (Right False) nextResponse
- _ -> processResponse (Left (ProtocolError ("Unexpected value of the \"integer_datetimes\" setting: " <> (fromString . show) value))) nextResponse
- _ -> processResponse state nextResponse
- ReadyForQueryResponse _ -> return state
- otherResponse -> do
- discardResponse otherResponse
- nextResponse <- fetchResponse
- processResponse state nextResponse
-
-authenticationResult :: InterpretResponses AuthenticationResult
-authenticationResult =
- do
- authenticationStatusResult <- authenticationStatus
- case authenticationStatusResult of
- NeedClearTextPasswordAuthenticationStatus -> return (NeedClearTextPasswordAuthenticationResult)
- NeedMD5PasswordAuthenticationStatus salt -> return (NeedMD5PasswordAuthenticationResult salt)
- OkAuthenticationStatus -> OkAuthenticationResult <$> parameters
-
-parseComplete :: InterpretResponses ()
-parseComplete =
- matchResponse $ \case
- ParseCompleteResponse -> Just (Right ())
- _ -> Nothing
-
-bindComplete :: InterpretResponses ()
-bindComplete =
- matchResponse $ \case
- BindCompleteResponse -> Just (Right ())
- _ -> Nothing
-
-readyForQuery :: InterpretResponses TransactionStatus
-readyForQuery =
- matchResponse $ \case
- ReadyForQueryResponse transactionStatus -> Just (Right transactionStatus)
- _ -> Nothing
diff --git a/library/Hasql/Core/Loops/Interpreter.hs b/library/Hasql/Core/Loops/Interpreter.hs
deleted file mode 100644
index c322198..0000000
--- a/library/Hasql/Core/Loops/Interpreter.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-module Hasql.Core.Loops.Interpreter where
-
-import Hasql.Prelude
-import Hasql.Core.Model
-import qualified Hasql.Core.MessageTypeNames as H
-import qualified Hasql.Core.InterpretResponses as C
-import qualified Data.Vector as B
-
-
-data ResultProcessor =
- forall result. ResultProcessor !(C.InterpretResponses result) !(Either Error result -> IO ())
-
-loop :: IO Response -> IO (Maybe ResultProcessor) -> (Notification -> IO ()) -> IO ()
-loop fetchResponse fetchResultProcessor sendNotification =
- forever $ do
- response <- fetchResponse
- fetchResult <- fetchResultProcessor
- case fetchResult of
- Just (ResultProcessor (C.InterpretResponses processResponses) sendResult) ->
- do
- newFetchResponse <- backtrackFetch response fetchResponse
- sendResult =<< processResponses newFetchResponse (interpretAsyncResponse sendNotification)
- Nothing ->
- interpretAsyncResponse sendNotification response
-
-interpretAsyncResponse :: (Notification -> IO ()) -> Response -> IO ()
-interpretAsyncResponse sendNotification response =
- case response of
- NotificationResponse a b c -> sendNotification (Notification a b c)
- _ -> return ()
-
-{-|
-Append one element to a fetching action.
--}
-backtrackFetch :: a -> IO a -> IO (IO a)
-backtrackFetch element fetch =
- do
- notFirstRef <- newIORef False
- return $ do
- notFirst <- readIORef notFirstRef
- if notFirst
- then fetch
- else do
- writeIORef notFirstRef True
- return element
diff --git a/library/Hasql/Core/Loops/Receiver.hs b/library/Hasql/Core/Loops/Receiver.hs
deleted file mode 100644
index 25d65db..0000000
--- a/library/Hasql/Core/Loops/Receiver.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-module Hasql.Core.Loops.Receiver where
-
-import Hasql.Prelude
-import Hasql.Core.Model
-import qualified Hasql.Core.Socket as A
-import qualified Data.ByteString as B
-import qualified Scanner as C
-import qualified Hasql.Core.Scanner as D
-
-
-{-# INLINABLE loop #-}
-loop :: A.Socket -> (Response -> IO ()) -> (Text -> IO ()) -> IO ()
-loop socket sendResponse reportError =
- processScannerResult (C.More (C.scan D.response))
- where
- processScannerResult =
- \case
- C.More consume -> do
- receivingResult <- A.receive socket (shiftL 2 12)
- case receivingResult of
- Right bytes ->
- if B.null bytes
- then reportError "Connection interrupted"
- else processScannerResult (consume bytes)
- Left msg ->
- reportError msg
- C.Done remainders responseMaybe -> do
- traverse_ sendResponse responseMaybe
- if B.null remainders
- then processScannerResult (C.More (C.scan D.response))
- else processScannerResult (C.scan D.response remainders)
- C.Fail remainders message -> do
- reportError (fromString message)
diff --git a/library/Hasql/Core/Loops/Sender.hs b/library/Hasql/Core/Loops/Sender.hs
deleted file mode 100644
index dbabcb9..0000000
--- a/library/Hasql/Core/Loops/Sender.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-module Hasql.Core.Loops.Sender where
-
-import Hasql.Prelude
-import qualified Hasql.Core.Socket as A
-import qualified Data.ByteString as B
-
-
-{-# INLINABLE loop #-}
-loop :: A.Socket -> IO ByteString -> (Text -> IO ()) -> IO ()
-loop socket getNextChunk reportError =
- forever $ do
- bytes <- getNextChunk
- resultOfSending <- A.send socket bytes
- case resultOfSending of
- Right () -> return ()
- Left msg -> reportError msg
diff --git a/library/Hasql/Core/Loops/Serializer.hs b/library/Hasql/Core/Loops/Serializer.hs
deleted file mode 100644
index f88f8ef..0000000
--- a/library/Hasql/Core/Loops/Serializer.hs
+++ /dev/null
@@ -1,50 +0,0 @@
-module Hasql.Core.Loops.Serializer where
-
-import Hasql.Prelude
-import qualified ByteString.StrictBuilder as D
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Internal as C
-
-
-data Message =
- SerializeMessage !D.Builder |
- FlushMessage
-
-loop :: IO Message -> (ByteString -> IO ()) -> IO ()
-loop getMessage sendBytes =
- startAnew
- where
- size =
- shiftL 2 12
- startAnew =
- do
- fp <- mallocForeignPtrBytes size
- processNextMessage fp 0
- processNextMessage !fp !offset =
- do
- message <- getMessage
- case message of
- SerializeMessage builder ->
- D.builderPtrFiller builder $ \spaceRequired write -> serialize fp offset spaceRequired write
- FlushMessage ->
- do
- sendBytes (C.PS fp 0 offset)
- startAnew
- serialize !fp !offset !spaceRequired !write =
- if size - offset >= spaceRequired
- then do
- withForeignPtr fp (\p -> write (plusPtr p offset))
- processNextMessage fp (offset + spaceRequired)
- else do
- when (offset >= 0) (sendBytes (C.PS fp 0 offset))
- if spaceRequired >= size
- then do
- newFP <- mallocForeignPtrBytes spaceRequired
- withForeignPtr newFP write
- sendBytes (C.PS newFP 0 spaceRequired)
- startAnew
- else do
- newFP <- mallocForeignPtrBytes size
- withForeignPtr newFP write
- processNextMessage newFP spaceRequired
-
diff --git a/library/Hasql/Core/MessageTypeNames.hs b/library/Hasql/Core/MessageTypeNames.hs
deleted file mode 100644
index 4c0e394..0000000
--- a/library/Hasql/Core/MessageTypeNames.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-module Hasql.Core.MessageTypeNames where
-
-import Hasql.Prelude
-
-
-string :: Word8 -> String
-string =
- \case
- 82 -> "Authentication"
- 75 -> "KeyData"
- 50 -> "BindComplete"
- 51 -> "CloseComplete"
- 67 -> "CommandComplete"
- 100 -> "CopyOutData"
- 99 -> "CopyOutDone"
- 71 -> "CopyInResponse"
- 72 -> "CopyOut"
- 87 -> "CopyBoth"
- 68 -> "DataRow"
- 73 -> "EmptyQuery"
- 69 -> "Error"
- 86 -> "FunctionCall"
- 110 -> "NoData"
- 78 -> "Notice"
- 65 -> "Notification"
- 116 -> "ParameterDescription"
- 83 -> "ParameterStatus"
- 49 -> "ParseComplete"
- 115 -> "PortalSuspended"
- 90 -> "ReadyForQuery"
- 84 -> "RowDescription"
- x -> showString "Unknown message type: " (show x)
diff --git a/library/Hasql/Core/MessageTypePredicates.hs b/library/Hasql/Core/MessageTypePredicates.hs
deleted file mode 100644
index f1d2b33..0000000
--- a/library/Hasql/Core/MessageTypePredicates.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-module Hasql.Core.MessageTypePredicates where
-
-import Hasql.Prelude
-
-
-authentication = (== 82) :: Word8 -> Bool
-keyData = (== 75) :: Word8 -> Bool
-bindComplete = (== 50) :: Word8 -> Bool
-closeComplete = (== 51) :: Word8 -> Bool
-commandComplete = (== 67) :: Word8 -> Bool
-copyOutData = (== 100) :: Word8 -> Bool
-copyOutDone = (== 99) :: Word8 -> Bool
-copyInResponse = (== 71) :: Word8 -> Bool
-copyOut = (== 72) :: Word8 -> Bool
-copyBoth = (== 87) :: Word8 -> Bool
-dataRow = (== 68) :: Word8 -> Bool
-emptyQuery = (== 73) :: Word8 -> Bool
-error = (== 69) :: Word8 -> Bool
-functionCall = (== 86) :: Word8 -> Bool
-noData = (== 110) :: Word8 -> Bool
-notice = (== 78) :: Word8 -> Bool
-notification = (== 65) :: Word8 -> Bool
-parameterDescription = (== 116) :: Word8 -> Bool
-parameterStatus = (== 83) :: Word8 -> Bool
-parseComplete = (== 49) :: Word8 -> Bool
-portalSuspended = (== 115) :: Word8 -> Bool
-readyForQuery = (== 90) :: Word8 -> Bool
-rowDescription = (== 84) :: Word8 -> Bool
diff --git a/library/Hasql/Core/Model.hs b/library/Hasql/Core/Model.hs
deleted file mode 100644
index e8342a8..0000000
--- a/library/Hasql/Core/Model.hs
+++ /dev/null
@@ -1,69 +0,0 @@
-module Hasql.Core.Model where
-
-import Hasql.Prelude hiding (State, peek)
-
-
-data Response =
- DataRowResponse !(Vector (Maybe ByteString)) |
- CommandCompleteResponse !Int |
- ReadyForQueryResponse !TransactionStatus |
- ParseCompleteResponse |
- BindCompleteResponse |
- EmptyQueryResponse |
- NotificationResponse !Word32 !ByteString !ByteString |
- ErrorResponse !ByteString !ByteString |
- AuthenticationResponse !AuthenticationStatus |
- ParameterStatusResponse !ByteString !ByteString
- deriving (Show)
-
-data AuthenticationStatus =
- NeedClearTextPasswordAuthenticationStatus |
- NeedMD5PasswordAuthenticationStatus !ByteString |
- OkAuthenticationStatus
- deriving (Show)
-
-data TransactionStatus =
- IdleTransactionStatus |
- ActiveTransactionStatus |
- FailedTransactionStatus
- deriving (Show)
-
-data AuthenticationResult =
- NeedClearTextPasswordAuthenticationResult |
- NeedMD5PasswordAuthenticationResult !ByteString |
- OkAuthenticationResult !Bool
-
-data Notification = Notification !Word32 !ByteString !ByteString deriving (Show)
-
-data Error =
- {-|
- An erroneous result received from the DB.
- The components are:
-
- * The SQLSTATE code for the error. The SQLSTATE code identifies the type of error that has occurred;
- it can be used by front-end applications to perform specific operations (such as error handling)
- in response to a particular database error.
- For a list of the possible SQLSTATE codes, see Appendix A.
- This field is not localizable, and is always present.
-
- * The primary human-readable error message (typically one line). Always present.
- -}
- BackendError !ByteString !ByteString |
- {-|
- Can happen as a result of an incorrect decoder being applied.
- -}
- DecodingError !Text |
- {-|
- Problems with the connection.
- -}
- TransportError !Text |
- {-|
- An unexpected or broken data packet received from the server.
- Can happen as a result of
- the server sending an unsupported message or
- something interfering
- in the communication channel.
- This error type is highly unlikely.
- -}
- ProtocolError !Text
- deriving (Show, Eq)
diff --git a/library/Hasql/Core/NoticeFieldTypes.hs b/library/Hasql/Core/NoticeFieldTypes.hs
deleted file mode 100644
index ef58fbd..0000000
--- a/library/Hasql/Core/NoticeFieldTypes.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-module Hasql.Core.NoticeFieldTypes where
-
-import Hasql.Prelude
-
-
-code = 0x43 :: Word8
-column = 0x63 :: Word8
-constraint = 0x6E :: Word8
-context = 0x57 :: Word8
-dataType = 0x64 :: Word8
-detail = 0x44 :: Word8
-file = 0x46 :: Word8
-hint = 0x48 :: Word8
-internalPosition = 0x70 :: Word8
-internalQuery = 0x71 :: Word8
-line = 0x4C :: Word8
-message = 0x4D :: Word8
-position = 0x50 :: Word8
-routine = 0x52 :: Word8
-schema = 0x73 :: Word8
-severity = 0x53 :: Word8
-table = 0x74 :: Word8
diff --git a/library/Hasql/Core/OID/Array.hs b/library/Hasql/Core/OID/Array.hs
deleted file mode 100644
index c8e5a1d..0000000
--- a/library/Hasql/Core/OID/Array.hs
+++ /dev/null
@@ -1,73 +0,0 @@
-module Hasql.Core.OID.Array where
-
-import Hasql.Prelude
-
-
-abstime :: Word32 = 1023
-aclitem :: Word32 = 1034
-bit :: Word32 = 1561
-bool :: Word32 = 1000
-box :: Word32 = 1020
-bpchar :: Word32 = 1014
-bytea :: Word32 = 1001
-char :: Word32 = 1002
-cid :: Word32 = 1012
-cidr :: Word32 = 651
-circle :: Word32 = 719
-cstring :: Word32 = 1263
-date :: Word32 = 1182
-daterange :: Word32 = 3913
-float4 :: Word32 = 1021
-float8 :: Word32 = 1022
-gtsvector :: Word32 = 3644
-inet :: Word32 = 1041
-int2 :: Word32 = 1005
-int2vector :: Word32 = 1006
-int4 :: Word32 = 1007
-int4range :: Word32 = 3905
-int8 :: Word32 = 1016
-int8range :: Word32 = 3927
-interval :: Word32 = 1187
-json :: Word32 = 199
-jsonb :: Word32 = 3807
-line :: Word32 = 629
-lseg :: Word32 = 1018
-macaddr :: Word32 = 1040
-money :: Word32 = 791
-name :: Word32 = 1003
-numeric :: Word32 = 1231
-numrange :: Word32 = 3907
-oid :: Word32 = 1028
-oidvector :: Word32 = 1013
-path :: Word32 = 1019
-point :: Word32 = 1017
-polygon :: Word32 = 1027
-record :: Word32 = 2287
-refcursor :: Word32 = 2201
-regclass :: Word32 = 2210
-regconfig :: Word32 = 3735
-regdictionary :: Word32 = 3770
-regoper :: Word32 = 2208
-regoperator :: Word32 = 2209
-regproc :: Word32 = 1008
-regprocedure :: Word32 = 2207
-regtype :: Word32 = 2211
-reltime :: Word32 = 1024
-text :: Word32 = 1009
-tid :: Word32 = 1010
-time :: Word32 = 1183
-timestamp :: Word32 = 1115
-timestamptz :: Word32 = 1185
-timetz :: Word32 = 1270
-tinterval :: Word32 = 1025
-tsquery :: Word32 = 3645
-tsrange :: Word32 = 3909
-tstzrange :: Word32 = 3911
-tsvector :: Word32 = 3643
-txid_snapshot :: Word32 = 2949
-unknown :: Word32 = 705
-uuid :: Word32 = 2951
-varbit :: Word32 = 1563
-varchar :: Word32 = 1015
-xid :: Word32 = 1011
-xml :: Word32 = 143
diff --git a/library/Hasql/Core/OID/Primitive.hs b/library/Hasql/Core/OID/Primitive.hs
deleted file mode 100644
index 067326f..0000000
--- a/library/Hasql/Core/OID/Primitive.hs
+++ /dev/null
@@ -1,74 +0,0 @@
-module Hasql.Core.OID.Primitive where
-
-import Hasql.Prelude
-
-
-abstime :: Word32 = 702
-aclitem :: Word32 = 1033
-bit :: Word32 = 1560
-bool :: Word32 = 16
-box :: Word32 = 603
-bpchar :: Word32 = 1042
-bytea :: Word32 = 17
-char :: Word32 = 18
-cid :: Word32 = 29
-cidr :: Word32 = 650
-circle :: Word32 = 718
-cstring :: Word32 = 2275
-date :: Word32 = 1082
-daterange :: Word32 = 3912
-float4 :: Word32 = 700
-float8 :: Word32 = 701
-gtsvector :: Word32 = 3642
-inet :: Word32 = 869
-int2 :: Word32 = 21
-int2vector :: Word32 = 22
-int4 :: Word32 = 23
-int4range :: Word32 = 3904
-int8 :: Word32 = 20
-int8range :: Word32 = 3926
-interval :: Word32 = 1186
-json :: Word32 = 114
-jsonb :: Word32 = 3802
-line :: Word32 = 628
-lseg :: Word32 = 601
-macaddr :: Word32 = 829
-money :: Word32 = 790
-name :: Word32 = 19
-numeric :: Word32 = 1700
-numrange :: Word32 = 3906
-oid :: Word32 = 26
-oidvector :: Word32 = 30
-path :: Word32 = 602
-point :: Word32 = 600
-polygon :: Word32 = 604
-record :: Word32 = 2249
-refcursor :: Word32 = 1790
-regclass :: Word32 = 2205
-regconfig :: Word32 = 3734
-regdictionary :: Word32 = 3769
-regoper :: Word32 = 2203
-regoperator :: Word32 = 2204
-regproc :: Word32 = 24
-regprocedure :: Word32 = 2202
-regtype :: Word32 = 2206
-reltime :: Word32 = 703
-text :: Word32 = 25
-tid :: Word32 = 27
-time :: Word32 = 1083
-timestamp :: Word32 = 1114
-timestamptz :: Word32 = 1184
-timetz :: Word32 = 1266
-tinterval :: Word32 = 704
-tsquery :: Word32 = 3615
-tsrange :: Word32 = 3908
-tstzrange :: Word32 = 3910
-tsvector :: Word32 = 3614
-txid_snapshot :: Word32 = 2970
-unknown :: Word32 = 705
-uuid :: Word32 = 2950
-varbit :: Word32 = 1562
-varchar :: Word32 = 1043
-void :: Word32 = 2278
-xid :: Word32 = 28
-xml :: Word32 = 142
diff --git a/library/Hasql/Core/ParseDataRow.hs b/library/Hasql/Core/ParseDataRow.hs
deleted file mode 100644
index 9827b70..0000000
--- a/library/Hasql/Core/ParseDataRow.hs
+++ /dev/null
@@ -1,38 +0,0 @@
-module Hasql.Core.ParseDataRow where
-
-import Hasql.Prelude
-import qualified BinaryParser as D
-import qualified Data.Vector as A
-
-
-{-|
-A specification for processing of DataRow messages.
-
-It is assumed that the size of the input vector is checked externally.
--}
-data ParseDataRow result =
- ParseDataRow !Int !(Vector (Maybe ByteString) -> Int -> Either Text result)
-
-deriving instance Functor ParseDataRow
-
-instance Applicative ParseDataRow where
- pure x =
- ParseDataRow 0 (\_ _ -> Right x)
- (<*>) (ParseDataRow leftSize leftInterpreter) (ParseDataRow rightSize rightInterpreter) =
- ParseDataRow
- (leftSize + rightSize)
- (\vec !index -> leftInterpreter vec index <*> rightInterpreter vec (index + leftSize))
-
-nullableColumn :: D.BinaryParser column -> ParseDataRow (Maybe column)
-nullableColumn parser =
- ParseDataRow 1 $ \vec index ->
- either (Left . mappend ("Column " <> (fromString . show) index <> ": ")) Right $
- traverse (D.run parser) (A.unsafeIndex vec index)
-
-column :: D.BinaryParser column -> ParseDataRow column
-column parser =
- ParseDataRow 1 $ \vec index ->
- either (Left . mappend ("Column " <> (fromString . show) index <> ": ")) Right $
- case A.unsafeIndex vec index of
- Just bytes -> D.run parser bytes
- Nothing -> Left "Unexpected NULL"
diff --git a/library/Hasql/Core/PreparedStatementRegistry.hs b/library/Hasql/Core/PreparedStatementRegistry.hs
deleted file mode 100644
index c4d579f..0000000
--- a/library/Hasql/Core/PreparedStatementRegistry.hs
+++ /dev/null
@@ -1,49 +0,0 @@
-module Hasql.Core.PreparedStatementRegistry
-(
- Registry,
- nil,
- lookupOrRegister,
-)
-where
-
-import Hasql.Prelude hiding (lookup)
-import qualified Data.HashMap.Strict as A
-import qualified ByteString.StrictBuilder as B
-
-
--- |
--- Local statement key.
-data LocalKey =
- LocalKey !ByteString !(Vector Word32)
- deriving (Show, Eq)
-
-instance Hashable LocalKey where
- {-# INLINE hashWithSalt #-}
- hashWithSalt salt (LocalKey template types) =
- hashWithSalt salt template
-
-
-data Registry =
- Registry !(A.HashMap LocalKey ByteString) !Word
-
-{-# INLINE nil #-}
-nil :: Registry
-nil =
- Registry A.empty 0
-
-{-# INLINABLE lookupOrRegister #-}
-lookupOrRegister :: ByteString -> Vector Word32 -> Registry -> (Either ByteString ByteString, Registry)
-lookupOrRegister template oids (Registry hashMap counter) =
- case A.lookup localKey hashMap of
- Just remoteKey ->
- (Right remoteKey, Registry hashMap counter)
- Nothing ->
- (Left remoteKey, Registry newHashMap (succ counter))
- where
- remoteKey =
- B.builderBytes (B.asciiIntegral counter)
- newHashMap =
- A.insert localKey remoteKey hashMap
- where
- localKey =
- LocalKey template oids
diff --git a/library/Hasql/Core/Protocol/Decoding.hs b/library/Hasql/Core/Protocol/Decoding.hs
deleted file mode 100644
index cd4aaf6..0000000
--- a/library/Hasql/Core/Protocol/Decoding.hs
+++ /dev/null
@@ -1,207 +0,0 @@
-module Hasql.Core.Protocol.Decoding where
-
-import Hasql.Prelude
-import Hasql.Core.Protocol.Model
-import BinaryParser
-import qualified Data.Vector as A
-import qualified Hasql.Core.ParseDataRow as F
-
-
-{-# INLINE word8 #-}
-word8 :: BinaryParser Word8
-word8 =
- byte
-
-{-# INLINE word16 #-}
-word16 :: BinaryParser Word16
-word16 =
- beWord16
-
-{-# INLINE word32 #-}
-word32 :: BinaryParser Word32
-word32 =
- beWord32
-
-{-# INLINE int32 #-}
-int32 :: BinaryParser Int32
-int32 =
- fromIntegral <$> beWord32
-
-{-# INLINE messageTypeAndLength #-}
-messageTypeAndLength :: (MessageType -> PayloadLength -> a) -> BinaryParser a
-messageTypeAndLength cont =
- cont <$> messageType <*> payloadLength
-
-{-# INLINE messageType #-}
-messageType :: BinaryParser MessageType
-messageType =
- MessageType <$> word8
-
-{-# INLINE payloadLength #-}
-payloadLength :: BinaryParser PayloadLength
-payloadLength =
- PayloadLength . subtract 4 . fromIntegral <$> word32
-
-{-# INLINE nullableSizedValue #-}
-nullableSizedValue :: BinaryParser a -> BinaryParser (Maybe a)
-nullableSizedValue value =
- do
- size <- int32
- case size of
- -1 -> return Nothing
- _ -> sized (fromIntegral size) (fmap Just value)
-
-{-# INLINE sizedValue #-}
-sizedValue :: BinaryParser a -> BinaryParser a
-sizedValue value =
- do
- size <- int32
- case size of
- -1 -> failure "Unexpected null"
- _ -> sized (fromIntegral size) value
-
-{-|
-Extracts the number of affected rows from the body of the CommandComplete message.
--}
-{-# INLINE commandCompleteMessageAffectedRows #-}
-commandCompleteMessageAffectedRows :: BinaryParser Int
-commandCompleteMessageAffectedRows =
- do
- header <- bytesWhile byteIsUpperLetter
- byte
- case header of
- "INSERT" -> unitWhile byteIsDecimal *> byte *> asciiIntegral <* byte
- _ -> asciiIntegral <* byte
- where
- byteIsUpperLetter byte =
- byte - 65 <= 25
- byteIsDecimal byte =
- byte - 48 <= 9
-
-{-|
-The essential components of the error (or notice) message.
--}
-{-# INLINE errorMessage #-}
-errorMessage :: (ByteString -> ByteString -> errorMessage) -> BinaryParser errorMessage
-errorMessage errorMessage =
- do
- tupleFn <- loop id
- case tupleFn (Nothing, Nothing) of
- (Just v1, Just v2) -> return (errorMessage v1 v2)
- _ -> failure "Some of the error fields are missing"
- where
- loop state =
- (noticeField fieldState >>= id >>= loop) <|> pure state
- where
- fieldState =
- \case
- CodeNoticeFieldType -> \payload -> pure (state . (\(v1, v2) -> (Just payload, v2)))
- MessageNoticeFieldType -> \payload -> pure (state . (\(v1, v2) -> (v1, Just payload)))
- _ -> \_ -> pure state
-
-{-# INLINE noticeField #-}
-noticeField :: (NoticeFieldType -> ByteString -> a) -> BinaryParser a
-noticeField cont =
- cont <$> noticeFieldType <*> nullTerminatedString
-
-{-# INLINE noticeFieldType #-}
-noticeFieldType :: BinaryParser NoticeFieldType
-noticeFieldType =
- NoticeFieldType <$> word8
-
-{-# INLINE nullTerminatedString #-}
-nullTerminatedString :: BinaryParser ByteString
-nullTerminatedString =
- bytesWhile (/= 0) <* byte
-
-{-# INLINE protocolVersion #-}
-protocolVersion :: BinaryParser (Word16, Word16)
-protocolVersion =
- (,) <$> word16 <*> word16
-
-{-# INLINE authenticationMessage #-}
-authenticationMessage :: BinaryParser AuthenticationMessage
-authenticationMessage =
- do
- method <- word32
- case method of
- 0 -> return OkAuthenticationMessage
- 3 -> return ClearTextPasswordAuthenticationMessage
- 5 -> MD5PasswordAuthenticationMessage <$> remainders
- _ -> failure ("Unsupported authentication method: " <> (fromString . show) method)
-
-{-# INLINE notificationMessage #-}
-notificationMessage :: (Word32 -> ByteString -> ByteString -> result) -> BinaryParser result
-notificationMessage cont =
- cont <$> word32 <*> nullTerminatedString <*> nullTerminatedString
-
-{-# INLINE dataRowMessage #-}
-dataRowMessage :: (Word16 -> BinaryParser a) -> BinaryParser a
-dataRowMessage contentsParser =
- do
- amountOfColumns <- word16
- contentsParser amountOfColumns
-
-{-# INLINE parseDataRow #-}
-parseDataRow :: F.ParseDataRow a -> BinaryParser a
-parseDataRow (F.ParseDataRow columnsAmount vectorFn) =
- do
- actualColumnsAmount <- fromIntegral <$> word16
- if actualColumnsAmount == columnsAmount
- then do
- bytesVector <- A.replicateM actualColumnsAmount sizedBytes
- either throwError return (vectorFn bytesVector 0)
- else throwError ("Invalid amount of columns: " <> (fromString . show) actualColumnsAmount <>
- ", expecting " <> (fromString . show) columnsAmount)
-
-{-|
-ParameterStatus (B)
-Byte1('S')
-Identifies the message as a run-time parameter status report.
-
-Int32
-Length of message contents in bytes, including self.
-
-String
-The name of the run-time parameter being reported.
-
-String
-The current value of the parameter.
--}
-{-# INLINE parameterStatusMessagePayloadKeyValue #-}
-parameterStatusMessagePayloadKeyValue :: (ByteString -> ByteString -> a) -> BinaryParser a
-parameterStatusMessagePayloadKeyValue cont =
- cont <$> nullTerminatedString <*> nullTerminatedString
-
-{-|
-Int16
-The number of column values that follow (possibly zero).
-
-Next, the following pair of fields appear for each column:
-
-Int32
-The length of the column value, in bytes (this count does not include itself). Can be zero. As a special case, -1 indicates a NULL column value. No value bytes follow in the NULL case.
-
-Byten
-The value of the column, in the format indicated by the associated format code. n is the above length.
--}
-vector :: BinaryParser element -> BinaryParser (Vector element)
-vector element =
- do
- size <- fromIntegral <$> word16
- A.replicateM size element
-
-{-|
-Int32
-The length of the column value, in bytes (this count does not include itself). Can be zero. As a special case, -1 indicates a NULL column value. No value bytes follow in the NULL case.
-
-Byten
-The value of the column, in the format indicated by the associated format code. n is the above length.
--}
-sizedBytes :: BinaryParser (Maybe ByteString)
-sizedBytes =
- do
- size <- fromIntegral <$> word32
- if size == -1
- then return Nothing
- else Just <$> bytesOfSize size
diff --git a/library/Hasql/Core/Protocol/Encoding.hs b/library/Hasql/Core/Protocol/Encoding.hs
deleted file mode 100644
index f7f7ace..0000000
--- a/library/Hasql/Core/Protocol/Encoding.hs
+++ /dev/null
@@ -1,210 +0,0 @@
-{-|
-https://www.postgresql.org/docs/9.6/static/protocol-message-formats.html
--}
-module Hasql.Core.Protocol.Encoding where
-
-import Hasql.Prelude
-import Hasql.Core.Protocol.Model
-import ByteString.StrictBuilder
-import qualified Data.Vector as A
-import qualified Crypto.Hash as B
-
-
--- * Constants
--------------------------
-
-{-# NOINLINE nullByte #-}
-nullByte =
- word8 0
-
-{-# NOINLINE nullSize #-}
-nullSize =
- int32BE (-1)
-
--- *
--------------------------
-
-array elementBuilder vector =
- word16BE (fromIntegral (A.length vector)) <>
- foldMap elementBuilder vector
-
-sizedPayload payload =
- word32BE (fromIntegral (builderLength payload) + 4) <> payload
-
-startUpMessage majorProtocolVersion minorProtocolVersion username databaseMaybe runtimeParameters =
- sizedPayload (protocolVersion majorProtocolVersion minorProtocolVersion <> parameters <> nullByte)
- where
- parameters =
- parameter "user" username <>
- foldMap database databaseMaybe <>
- foldMap (uncurry parameter) runtimeParameters
- where
- parameter name value =
- nullTerminatedString name <> nullTerminatedString value
- database database =
- parameter "database" database
-
-{-# NOINLINE syncMessage #-}
-syncMessage =
- asciiChar 'S' <> word32BE 4
-
-{-# NOINLINE terminateMessage #-}
-terminateMessage =
- asciiChar 'X' <> word32BE 4
-
-protocolVersion major minor =
- word16BE major <> word16BE minor
-
-nullTerminatedString string =
- bytes string <> nullByte
-
-{-# NOINLINE passwordMessageIdentifier #-}
-passwordMessageIdentifier =
- asciiChar 'p'
-
-passwordMessage payload =
- passwordMessageIdentifier <> sizedPayload (payload <> nullByte)
-
-clearTextPasswordMessage password =
- passwordMessage (bytes password)
-
-md5PasswordMessage username password salt =
- passwordMessage ("md5" <> bytes (md5HexBytes (md5HexBytes (password <> username) <> salt)))
- where
- md5HexBytes =
- fromString . show . B.hashWith B.MD5
-
-{-# NOINLINE parseMessageIdentifier #-}
-parseMessageIdentifier =
- asciiChar 'P'
-
-{-|
-Parse (F)
-Byte1('P')
-Identifies the message as a Parse command.
-
-Int32
-Length of message contents in bytes, including self.
-
-String
-The name of the destination prepared statement (an empty string selects the unnamed prepared statement).
-
-String
-The query string to be parsed.
-
-Int16
-The number of parameter data types specified (can be zero). Note that this is not an indication of the number of parameters that might appear in the query string, only the number that the frontend wants to prespecify types for.
-
-Then, for each parameter, there is the following:
-
-Int32
-Specifies the object ID of the parameter data type. Placing a zero here is equivalent to leaving the type unspecified.
--}
-{-# INLINE parseMessage #-}
-parseMessage preparedStatementName query oids =
- parseMessageIdentifier <> sizedPayload payload
- where
- payload =
- nullTerminatedString preparedStatementName <>
- nullTerminatedString query <>
- array word32BE oids
-
-{-# NOINLINE bindMessageIdentifier #-}
-bindMessageIdentifier =
- asciiChar 'B'
-
-{-|
-Bind (F)
-Byte1('B')
-Identifies the message as a Bind command.
-
-Int32
-Length of message contents in bytes, including self.
-
-String
-The name of the destination portal (an empty string selects the unnamed portal).
-
-String
-The name of the source prepared statement (an empty string selects the unnamed prepared statement).
-
-Int16
-The number of parameter format codes that follow (denoted C below). This can be zero to indicate that there are no parameters or that the parameters all use the default format (text); or one, in which case the specified format code is applied to all parameters; or it can equal the actual number of parameters.
-
-Int16[C]
-The parameter format codes. Each must presently be zero (text) or one (binary).
-
-Int16
-The number of parameter values that follow (possibly zero). This must match the number of parameters needed by the query.
-
-Next, the following pair of fields appear for each parameter:
-
-Int32
-The length of the parameter value, in bytes (this count does not include itself). Can be zero. As a special case, -1 indicates a NULL parameter value. No value bytes follow in the NULL case.
-
-Byten
-The value of the parameter, in the format indicated by the associated format code. n is the above length.
-
-After the last parameter, the following fields appear:
-
-Int16
-The number of result-column format codes that follow (denoted R below). This can be zero to indicate that there are no result columns or that the result columns should all use the default format (text); or one, in which case the specified format code is applied to all result columns (if any); or it can equal the actual number of result columns of the query.
-
-Int16[R]
-The result-column format codes. Each must presently be zero (text) or one (binary).
--}
-binaryFormatBindMessage portalName preparedStatementName parameters =
- bindMessageIdentifier <> sizedPayload payload
- where
- payload =
- nullTerminatedString portalName <>
- nullTerminatedString preparedStatementName <>
- uniformBinaryFormatCodes <>
- array nullableSizedValue parameters <>
- uniformBinaryFormatCodes
-
-binaryFormatBindMessageWithEncodedParams portalName preparedStatementName paramsAmount encodedParams =
- bindMessageIdentifier <> sizedPayload payload
- where
- payload =
- nullTerminatedString portalName <>
- nullTerminatedString preparedStatementName <>
- uniformBinaryFormatCodes <>
- word16BE paramsAmount <>
- encodedParams <>
- uniformBinaryFormatCodes
-
-{-# NOINLINE uniformBinaryFormatCodes #-}
-uniformBinaryFormatCodes =
- word16BE 1 <> word16BE 1
-
-sizedValue value =
- word32BE (fromIntegral (builderLength value)) <> value
-
-nullableSizedValue =
- maybe nullSize sizedValue
-
-{-|
-Execute (F)
-Byte1('E')
-Identifies the message as an Execute command.
-
-Int32
-Length of message contents in bytes, including self.
-
-String
-The name of the portal to execute (an empty string selects the unnamed portal).
-
-Int32
-Maximum number of rows to return, if portal contains a query that returns rows (ignored otherwise). Zero denotes "no limit".
--}
-unlimitedExecuteMessage portalName =
- executeMessageIdentifier <> sizedPayload payload
- where
- payload =
- nullTerminatedString portalName <>
- word32BE 0
-
-{-# NOINLINE executeMessageIdentifier #-}
-executeMessageIdentifier =
- asciiChar 'E'
-
diff --git a/library/Hasql/Core/Protocol/Model.hs b/library/Hasql/Core/Protocol/Model.hs
deleted file mode 100644
index 5d3b68c..0000000
--- a/library/Hasql/Core/Protocol/Model.hs
+++ /dev/null
@@ -1,211 +0,0 @@
-module Hasql.Core.Protocol.Model where
-
-import Hasql.Prelude
-
-
-newtype DataFormat =
- DataFormat Word16
-
-pattern TextDataFormat =
- DataFormat 0
-
-pattern BinaryDataFormat =
- DataFormat 1
-
-
-{-|
-An encoded representation of the backend message type
--}
-newtype MessageType =
- MessageType Word8
- deriving (Eq, Ord)
-
-instance Show MessageType where
- show =
- \case
- AuthenticationMessageType -> "AuthenticationMessageType"
- KeyDataMessageType -> "KeyDataMessageType"
- BindCompleteMessageType -> "BindCompleteMessageType"
- CloseCompleteMessageType -> "CloseCompleteMessageType"
- CommandCompleteMessageType -> "CommandCompleteMessageType"
- CopyOutDataMessageType -> "CopyOutDataMessageType"
- CopyOutDoneMessageType -> "CopyOutDoneMessageType"
- CopyInResponseMessageType -> "CopyInResponseMessageType"
- CopyOutMessageType -> "CopyOutMessageType"
- CopyBothMessageType -> "CopyBothMessageType"
- DataRowMessageType -> "DataRowMessageType"
- EmptyQueryMessageType -> "EmptyQueryMessageType"
- ErrorMessageType -> "ErrorMessageType"
- FunctionCallMessageType -> "FunctionCallMessageType"
- NoDataMessageType -> "NoDataMessageType"
- NoticeMessageType -> "NoticeMessageType"
- NotificationMessageType -> "NotificationMessageType"
- ParameterDescriptionMessageType -> "ParameterDescriptionMessageType"
- ParameterStatusMessageType -> "ParameterStatusMessageType"
- ParseCompleteMessageType -> "ParseCompleteMessageType"
- PortalSuspendedMessageType -> "PortalSuspendedMessageType"
- ReadyForQueryMessageType -> "ReadyForQueryMessageType"
- RowDescriptionMessageType -> "RowDescriptionMessageType"
- MessageType x -> "MessageType " <> show x
-
-pattern AuthenticationMessageType =
- MessageType 82
-
-pattern KeyDataMessageType =
- MessageType 75
-
-pattern BindCompleteMessageType =
- MessageType 50
-
-pattern CloseCompleteMessageType =
- MessageType 51
-
-pattern CommandCompleteMessageType =
- MessageType 67
-
-pattern CopyOutDataMessageType =
- MessageType 100
-
-pattern CopyOutDoneMessageType =
- MessageType 99
-
-pattern CopyInResponseMessageType =
- MessageType 71
-
-pattern CopyOutMessageType =
- MessageType 72
-
-pattern CopyBothMessageType =
- MessageType 87
-
-pattern DataRowMessageType =
- MessageType 68
-
-pattern EmptyQueryMessageType =
- MessageType 73
-
-pattern ErrorMessageType =
- MessageType 69
-
-pattern FunctionCallMessageType =
- MessageType 86
-
-pattern NoDataMessageType =
- MessageType 110
-
-pattern NoticeMessageType =
- MessageType 78
-
-pattern NotificationMessageType =
- MessageType 65
-
-pattern ParameterDescriptionMessageType =
- MessageType 116
-
-pattern ParameterStatusMessageType =
- MessageType 83
-
-pattern ParseCompleteMessageType =
- MessageType 49
-
-pattern PortalSuspendedMessageType =
- MessageType 115
-
-pattern ReadyForQueryMessageType =
- MessageType 90
-
-pattern RowDescriptionMessageType =
- MessageType 84
-
-
-newtype PayloadLength =
- PayloadLength Int32
-
-pattern NullPayloadLength =
- PayloadLength (-1)
-
-
-data Payload =
- NullPayload |
- BytesPayload !ByteString
-
-
-newtype NoticeFieldType =
- NoticeFieldType Word8
-
-pattern CodeNoticeFieldType =
- NoticeFieldType 0x43
-
-pattern ColumnNoticeFieldType =
- NoticeFieldType 0x63
-
-pattern ConstraintNoticeFieldType =
- NoticeFieldType 0x6E
-
-pattern ContextNoticeFieldType =
- NoticeFieldType 0x57
-
-pattern DataTypeNoticeFieldType =
- NoticeFieldType 0x64
-
-pattern DetailNoticeFieldType =
- NoticeFieldType 0x44
-
-pattern FileNoticeFieldType =
- NoticeFieldType 0x46
-
-pattern HintNoticeFieldType =
- NoticeFieldType 0x48
-
-pattern InternalPositionNoticeFieldType =
- NoticeFieldType 0x70
-
-pattern InternalQueryNoticeFieldType =
- NoticeFieldType 0x71
-
-pattern LineNoticeFieldType =
- NoticeFieldType 0x4C
-
-pattern MessageNoticeFieldType =
- NoticeFieldType 0x4D
-
-pattern PositionNoticeFieldType =
- NoticeFieldType 0x50
-
-pattern RoutineNoticeFieldType =
- NoticeFieldType 0x52
-
-pattern SchemaNoticeFieldType =
- NoticeFieldType 0x73
-
-pattern SeverityNoticeFieldType =
- NoticeFieldType 0x53
-
-pattern TableNoticeFieldType =
- NoticeFieldType 0x74
-
-
-data Error =
- -- |
- -- An erroneous result received from the DB.
- -- The components are:
- --
- -- * The SQLSTATE code for the error. The SQLSTATE code identifies the type of error that has occurred;
- -- it can be used by front-end applications to perform specific operations (such as error handling)
- -- in response to a particular database error.
- -- For a list of the possible SQLSTATE codes, see Appendix A.
- -- This field is not localizable, and is always present.
- --
- -- * The primary human-readable error message (typically one line). Always present.
- Error !ByteString !ByteString
-
-
-data AuthenticationMessage =
- OkAuthenticationMessage |
- ClearTextPasswordAuthenticationMessage |
- MD5PasswordAuthenticationMessage !ByteString
- deriving (Show, Eq)
-
-
-data NotificationMessage =
- NotificationMessage !Word32 !ByteString !ByteString
diff --git a/library/Hasql/Core/Request.hs b/library/Hasql/Core/Request.hs
deleted file mode 100644
index 39b8e8d..0000000
--- a/library/Hasql/Core/Request.hs
+++ /dev/null
@@ -1,96 +0,0 @@
-module Hasql.Core.Request where
-
-import Hasql.Prelude
-import Hasql.Core.Model
-import qualified ByteString.StrictBuilder as B
-import qualified BinaryParser as D
-import qualified Hasql.Core.InterpretResponses as A
-import qualified Hasql.Core.Protocol.Encoding as K
-import qualified Hasql.Core.Protocol.Model as C
-import qualified Data.Vector as G
-
-
-{-|
-A builder of concatenated outgoing messages and
-a parser of the stream of incoming messages.
--}
-data Request result =
- Request !B.Builder !(A.InterpretResponses result)
-
-instance Functor Request where
- {-# INLINE fmap #-}
- fmap mapping (Request builder parse) =
- Request builder (fmap mapping parse)
-
-instance Applicative Request where
- {-# INLINE pure #-}
- pure =
- Request mempty . return
- {-# INLINE (<*>) #-}
- (<*>) (Request leftBuilder leftParse) (Request rightBuilder rightParse) =
- Request (leftBuilder <> rightBuilder) (leftParse <*> rightParse)
-
-{-# INLINE simple #-}
-simple :: B.Builder -> A.InterpretResponses result -> Request result
-simple builder ir =
- Request builder ir
-
-{-# INLINE parse #-}
-parse :: ByteString -> ByteString -> Vector Word32 -> Request ()
-parse preparedStatementName query oids =
- simple (K.parseMessage preparedStatementName query oids) A.parseComplete
-
-{-# INLINE bind #-}
-bind :: ByteString -> ByteString -> Vector (Maybe B.Builder) -> Request ()
-bind portalName preparedStatementName parameters =
- simple (K.binaryFormatBindMessage portalName preparedStatementName parameters) A.bindComplete
-
-{-# INLINE bindEncoded #-}
-bindEncoded :: ByteString -> ByteString -> Int -> B.Builder -> Request ()
-bindEncoded portalName preparedStatementName paramsAmount paramsBuilder =
- simple
- (K.binaryFormatBindMessageWithEncodedParams portalName preparedStatementName (fromIntegral paramsAmount) paramsBuilder)
- A.bindComplete
-
-{-# INLINE execute #-}
-execute :: ByteString -> A.InterpretResponses result -> Request result
-execute portalName pms =
- simple (K.unlimitedExecuteMessage portalName) pms
-
-{-# INLINE sync #-}
-sync :: Request TransactionStatus
-sync =
- simple K.syncMessage A.readyForQuery
-
-{-# INLINE startUp #-}
-startUp :: ByteString -> Maybe ByteString -> [(ByteString, ByteString)] -> Request AuthenticationResult
-startUp username databaseMaybe runtimeParameters =
- simple
- (K.startUpMessage 3 0 username databaseMaybe runtimeParameters)
- (A.authenticationResult)
-
-{-# INLINE clearTextPassword #-}
-clearTextPassword :: ByteString -> Request AuthenticationResult
-clearTextPassword password =
- simple
- (K.clearTextPasswordMessage password)
- (A.authenticationResult)
-
-{-# INLINE md5Password #-}
-md5Password :: ByteString -> ByteString -> ByteString -> Request AuthenticationResult
-md5Password username password salt =
- simple
- (K.md5PasswordMessage username password salt)
- (A.authenticationResult)
-
-{-# INLINE unparsedStatement #-}
-unparsedStatement :: ByteString -> ByteString -> Vector Word32 -> B.Builder -> A.InterpretResponses result -> Request result
-unparsedStatement name template oidVec bytesBuilder parseMessageStream =
- parse name template oidVec *>
- parsedStatement name template (G.length oidVec) bytesBuilder parseMessageStream
-
-{-# INLINE parsedStatement #-}
-parsedStatement :: ByteString -> ByteString -> Int -> B.Builder -> A.InterpretResponses result -> Request result
-parsedStatement name template paramsAmount bytesBuilder parseMessageStream =
- bindEncoded "" name paramsAmount bytesBuilder *>
- execute "" parseMessageStream
diff --git a/library/Hasql/Core/Scanner.hs b/library/Hasql/Core/Scanner.hs
deleted file mode 100644
index 9079626..0000000
--- a/library/Hasql/Core/Scanner.hs
+++ /dev/null
@@ -1,193 +0,0 @@
-module Hasql.Core.Scanner where
-
-import Hasql.Prelude
-import Hasql.Core.Model
-import Scanner (Scanner)
-import qualified Scanner as A
-import qualified Data.ByteString as B
-import qualified Data.Vector as D
-import qualified Hasql.Core.MessageTypePredicates as C
-import qualified Hasql.Core.NoticeFieldTypes as E
-
-
-{-# INLINE word8 #-}
-word8 :: Scanner Word8
-word8 =
- A.anyWord8
-
-{-# INLINE word16 #-}
-word16 :: Scanner Word16
-word16 =
- numOfSize 2
-
-{-# INLINE word32 #-}
-word32 :: Scanner Word32
-word32 =
- numOfSize 4
-
-{-# INLINE word64 #-}
-word64 :: Scanner Word64
-word64 =
- numOfSize 8
-
-{-# INLINE numOfSize #-}
-numOfSize :: (Bits a, Num a) => Int -> Scanner a
-numOfSize size =
- B.foldl' (\n h -> shiftL n 8 .|. fromIntegral h) 0 <$> A.take size
-
-{-# INLINE int32 #-}
-int32 :: Scanner Int32
-int32 =
- fromIntegral <$> word32
-
-{-# INLINE messageTypeAndLength #-}
-messageTypeAndLength :: (Word8 -> Word32 -> a) -> Scanner a
-messageTypeAndLength cont =
- cont <$> word8 <*> payloadLength
-
-{-# INLINE payloadLength #-}
-payloadLength :: (Integral a, Bits a) => Scanner a
-payloadLength =
- subtract 4 <$> numOfSize 4
-
-{-# INLINE messageTypeAndPayload #-}
-messageTypeAndPayload :: (Word8 -> ByteString -> a) -> Scanner a
-messageTypeAndPayload cont =
- cont <$> word8 <*> (payloadLength >>= A.take)
-
--- |
--- Integral number encoded in ASCII.
-{-# INLINE asciiIntegral #-}
-asciiIntegral :: Integral a => Scanner a
-asciiIntegral =
- B.foldl' step 0 <$> A.takeWhile byteIsDigit
- where
- byteIsDigit byte =
- byte - 48 <= 9
- step !state !byte =
- state * 10 + fromIntegral byte - 48
-
-{-# INLINE nullTerminatedString #-}
-nullTerminatedString :: Scanner ByteString
-nullTerminatedString =
- A.takeWhile (/= 0) <* A.anyWord8
-
--- * Responses
--------------------------
-
-{-# INLINE response #-}
-response :: Scanner (Maybe Response)
-response =
- do
- type_ <- word8
- bodyLength <- payloadLength
- if
- | C.dataRow type_ -> dataRowBody (Just . DataRowResponse)
- | C.commandComplete type_ -> commandCompleteBody (Just . CommandCompleteResponse)
- | C.readyForQuery type_ -> readyForQueryBody (Just . ReadyForQueryResponse)
- | C.parseComplete type_ -> pure (Just ParseCompleteResponse)
- | C.bindComplete type_ -> pure (Just BindCompleteResponse)
- | C.emptyQuery type_ -> pure (Just EmptyQueryResponse)
- | C.notification type_ -> Just <$> notificationBody NotificationResponse
- | C.error type_ -> Just <$> errorResponseBody bodyLength ErrorResponse
- | C.authentication type_ -> Just <$> authenticationBody AuthenticationResponse
- | C.parameterStatus type_ -> Just <$> parameterStatusBody ParameterStatusResponse
- | True -> A.take bodyLength $> Nothing
-
-{-# INLINE dataRowBody #-}
-dataRowBody :: (Vector (Maybe ByteString) -> result) -> Scanner result
-dataRowBody result =
- do
- amountOfColumns <- word16
- bytesVector <- D.replicateM (fromIntegral amountOfColumns) sizedBytes
- return (result bytesVector)
-
-{-# INLINE commandCompleteBody #-}
-commandCompleteBody :: (Int -> result) -> Scanner result
-commandCompleteBody result =
- do
- header <- A.takeWhile byteIsUpperLetter
- A.anyWord8
- count <- case header of
- "INSERT" -> A.skipWhile byteIsDigit *> A.anyWord8 *> asciiIntegral <* A.anyWord8
- _ -> asciiIntegral <* A.anyWord8
- return (result count)
- where
- byteIsUpperLetter byte =
- byte - 65 <= 25
- byteIsDigit byte =
- byte - 48 <= 9
-
-{-# INLINE readyForQueryBody #-}
-readyForQueryBody :: (TransactionStatus -> result) -> Scanner result
-readyForQueryBody result =
- do
- statusByte <- A.anyWord8
- case statusByte of
- 73 -> return (result IdleTransactionStatus)
- 84 -> return (result ActiveTransactionStatus)
- 69 -> return (result FailedTransactionStatus)
- _ -> fail (showString "Unexpected transaction status byte: " (show statusByte))
-
-{-# INLINE notificationBody #-}
-notificationBody :: (Word32 -> ByteString -> ByteString -> result) -> Scanner result
-notificationBody result =
- result <$> word32 <*> nullTerminatedString <*> nullTerminatedString
-
-{-# INLINE errorResponseBody #-}
-errorResponseBody :: Int -> (ByteString -> ByteString -> result) -> Scanner result
-errorResponseBody length result =
- do
- tuple <- iterate 0 Nothing Nothing
- A.anyWord8
- case tuple of
- (Just code, Just message) -> return (result code message)
- _ -> fail "Some of the required error fields are missing"
- where
- iterate !offset code message =
- if offset < length - 1
- then join (noticeField (\type_ payload ->
- if
- | type_ == E.code -> iterate (offset + 2 + B.length payload) (Just payload) message
- | type_ == E.message -> iterate (offset + 2 + B.length payload) code (Just payload)
- | True -> iterate (offset + 2 + B.length payload) code message))
- else return (code, message)
-
-{-# INLINE noticeField #-}
-noticeField :: (Word8 -> ByteString -> result) -> Scanner result
-noticeField result =
- result <$> word8 <*> nullTerminatedString
-
-{-# INLINE authenticationBody #-}
-authenticationBody :: (AuthenticationStatus -> result) -> Scanner result
-authenticationBody result =
- do
- status <- word32
- case status of
- 0 -> return (result OkAuthenticationStatus)
- 3 -> return (result NeedClearTextPasswordAuthenticationStatus)
- 5 -> do
- salt <- A.take 4
- return (result (NeedMD5PasswordAuthenticationStatus salt))
- _ -> fail ("Unsupported authentication status: " <> show status)
-
-{-# INLINE parameterStatusBody #-}
-parameterStatusBody :: (ByteString -> ByteString -> result) -> Scanner result
-parameterStatusBody result =
- result <$> nullTerminatedString <*> nullTerminatedString
-
-{-|
-Int32
-The length of the column value, in bytes (this count does not include itself). Can be zero. As a special case, -1 indicates a NULL column value. No value bytes follow in the NULL case.
-
-Byten
-The value of the column, in the format indicated by the associated format code. n is the above length.
--}
-{-# INLINE sizedBytes #-}
-sizedBytes :: Scanner (Maybe ByteString)
-sizedBytes =
- do
- size <- fromIntegral <$> word32
- if size == -1
- then return Nothing
- else Just <$> A.take size
diff --git a/library/Hasql/Core/Session.hs b/library/Hasql/Core/Session.hs
deleted file mode 100644
index 11330e1..0000000
--- a/library/Hasql/Core/Session.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module Hasql.Core.Session where
-
-import Hasql.Prelude
-import Hasql.Core.Model
-import qualified Hasql.Core.Batch as A
-
-
-newtype Session result =
- Session (F A.Batch result)
- deriving (Functor, Applicative, Monad)
-
-batch :: A.Batch result -> Session result
-batch = Session . liftF
diff --git a/library/Hasql/Core/Socket.hs b/library/Hasql/Core/Socket.hs
deleted file mode 100644
index e676c42..0000000
--- a/library/Hasql/Core/Socket.hs
+++ /dev/null
@@ -1,96 +0,0 @@
-module Hasql.Core.Socket where
-
-import Hasql.Prelude
-import Hasql.Core.Protocol.Model
-import qualified ByteString.StrictBuilder as F
-import qualified Data.ByteString as G
-import qualified Data.ByteString.Char8 as H
-import qualified Network as A
-import qualified Network.Socket as B
-import qualified Network.Socket.ByteString as C
-
-
-data ConnectionSettings =
- TCPConnectionSettings !ByteString !Int |
- SocketConnectionSettings !ByteString
-
-newtype Socket =
- Socket B.Socket
-
-{-# INLINE trySocketIO #-}
-trySocketIO :: IO a -> IO (Either Text a)
-trySocketIO io =
- catchIOError (fmap Right io) (return . Left . socketExceptionText)
- where
- socketExceptionText e =
- (fromString . show) e
-
-connect :: ConnectionSettings -> IO (Either Text Socket)
-connect =
- \case
- TCPConnectionSettings host port -> connectToHostAndPort host port
- SocketConnectionSettings socket -> $(todo "Implement connection thru socket")
-
-connectToHostAndPort :: ByteString -> Int -> IO (Either Text Socket)
-connectToHostAndPort host port =
- do
- runExceptT $ do
- addrList <- getAddressInfo
- addr <- headFailing "Invalid host or port" addrList
- socket <- initSocket (B.addrFamily addr) (B.addrSocketType addr) (B.addrProtocol addr)
- connect socket (B.addrAddress addr)
- return (Socket socket)
- where
- io =
- ExceptT . trySocketIO
- getAddressInfo =
- io (B.getAddrInfo (Just hints) (Just hostString) (Just portString))
- where
- hints =
- B.defaultHints {
- B.addrFlags = [B.AI_V4MAPPED],
- B.addrSocketType = B.Stream
- }
- portString =
- show port
- hostString =
- H.unpack host
- headFailing message =
- \case
- x : _ ->
- return x
- _ ->
- throwE message
- initSocket family socketType protocolNumber =
- io (B.socket family socketType protocolNumber)
- connect socket socketAddress =
- io (B.connect socket socketAddress)
-
-{-# INLINE close #-}
-close :: Socket -> IO ()
-close (Socket def) =
- B.close def
-
-{-# INLINE receive #-}
-receive :: Socket -> Int -> IO (Either Text ByteString)
-receive (Socket socket) amount =
- {-# SCC "receive" #-}
- trySocketIO (C.recv socket amount)
-
-{-# INLINE receiveToPtr #-}
-receiveToPtr :: Socket -> Ptr Word8 -> Int -> IO (Either Text Int)
-receiveToPtr (Socket socket) ptr amount =
- {-# SCC "receiveToPtr" #-}
- trySocketIO (B.recvBuf socket ptr amount)
-
-{-# INLINE send #-}
-send :: Socket -> ByteString -> IO (Either Text ())
-send (Socket socket) bytes =
- {-# SCC "send" #-}
- trySocketIO (C.sendAll socket bytes)
-
-{-# INLINE sendFromPtr #-}
-sendFromPtr :: Socket -> Ptr Word8 -> Int -> IO (Either Text Int)
-sendFromPtr (Socket socket) ptr amount =
- {-# SCC "sendFromPtr" #-}
- trySocketIO (B.sendBuf socket ptr amount)
diff --git a/library/Hasql/Core/Statement.hs b/library/Hasql/Core/Statement.hs
deleted file mode 100644
index da3b898..0000000
--- a/library/Hasql/Core/Statement.hs
+++ /dev/null
@@ -1,38 +0,0 @@
-module Hasql.Core.Statement where
-
-import Hasql.Prelude
-import Hasql.Core.Model
-import qualified Hasql.Core.EncodeParams as A
-import qualified Hasql.Core.DecodeResult as B
-import qualified Hasql.Core.InterpretResponses as C
-import qualified ByteString.StrictBuilder as D
-import qualified VectorBuilder.Vector as O
-
-
-data Statement params result =
- Statement
- ByteString
- (Vector Word32) (params -> D.Builder) (params -> D.Builder)
- (C.InterpretResponses result) (C.InterpretResponses result)
- Bool
-
-deriving instance Functor (Statement params)
-
-instance Profunctor Statement where
- {-# INLINE lmap #-}
- lmap fn (Statement template paramOIDs paramBytesBuilder1 paramBytesBuilder2 interpretResponses1 interpretResponses2 prepared) =
- Statement template paramOIDs (paramBytesBuilder1 . fn) (paramBytesBuilder2 . fn) interpretResponses1 interpretResponses2 prepared
- {-# INLINE rmap #-}
- rmap fn (Statement template paramOIDs paramBytesBuilder1 paramBytesBuilder2 interpretResponses1 interpretResponses2 prepared) =
- Statement template paramOIDs paramBytesBuilder1 paramBytesBuilder2 (fn <$> interpretResponses1) (fn <$> interpretResponses2) prepared
- {-# INLINE dimap #-}
- dimap lfn rfn (Statement template paramOIDs paramBytesBuilder1 paramBytesBuilder2 interpretResponses1 interpretResponses2 prepared) =
- Statement template paramOIDs (paramBytesBuilder1 . lfn) (paramBytesBuilder2 . lfn) (rfn <$> interpretResponses1) (rfn <$> interpretResponses2) prepared
-
-prepared :: ByteString -> A.EncodeParams params -> B.DecodeResult result -> Statement params result
-prepared template (A.EncodeParams oidVecBuilder builder1 builder2) (B.DecodeResult (ReaderT interpretResponses)) =
- Statement template (O.build oidVecBuilder) builder1 builder2 (interpretResponses True) (interpretResponses False) True
-
-unprepared :: ByteString -> A.EncodeParams params -> B.DecodeResult result -> Statement params result
-unprepared template (A.EncodeParams oidVecBuilder builder1 builder2) (B.DecodeResult (ReaderT interpretResponses)) =
- Statement template (O.build oidVecBuilder) builder1 builder2 (interpretResponses True) (interpretResponses False) False
diff --git a/library/Hasql/Core/UnauthenticatedSession.hs b/library/Hasql/Core/UnauthenticatedSession.hs
deleted file mode 100644
index cfa6426..0000000
--- a/library/Hasql/Core/UnauthenticatedSession.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-module Hasql.Core.UnauthenticatedSession where
-
-import Hasql.Prelude
-import Hasql.Core.Model
-import qualified Hasql.Core.Request as A
-
-
-newtype Session result =
- Session (F A.Request result)
- deriving (Functor, Applicative, Monad)
-
-{-# INLINE request #-}
-request :: A.Request result -> Session result
-request = Session . liftF
-
-{-# INLINE startUp #-}
-startUp :: ByteString -> Maybe ByteString -> [(ByteString, ByteString)] -> Session AuthenticationResult
-startUp username databaseMaybe runtimeParameters =
- request (A.startUp username databaseMaybe runtimeParameters)
-
-{-# INLINE clearTextPassword #-}
-clearTextPassword :: ByteString -> Session AuthenticationResult
-clearTextPassword password =
- request (A.clearTextPassword password)
-
-{-# INLINE md5Password #-}
-md5Password :: ByteString -> ByteString -> ByteString -> Session AuthenticationResult
-md5Password username password salt =
- request (A.md5Password username password salt)
-
-{-# INLINE handshake #-}
-handshake :: ByteString -> ByteString -> Maybe ByteString -> [(ByteString, ByteString)] -> Session (Either Text Bool)
-handshake username password databaseMaybe runtimeParameters =
- startUp username databaseMaybe runtimeParameters >>= handleFirstAuthenticationResult
- where
- handleFirstAuthenticationResult =
- \case
- OkAuthenticationResult idt -> return (Right idt)
- NeedClearTextPasswordAuthenticationResult -> clearTextPassword password >>= handleSecondAuthenticationResult
- NeedMD5PasswordAuthenticationResult salt -> md5Password username password salt >>= handleSecondAuthenticationResult
- handleSecondAuthenticationResult =
- \case
- OkAuthenticationResult idt -> return (Right idt)
- _ -> return (Left "Can't authenticate")
diff --git a/library/Hasql/DecodePrimitive.hs b/library/Hasql/DecodePrimitive.hs
deleted file mode 100644
index fa5af3d..0000000
--- a/library/Hasql/DecodePrimitive.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Hasql.DecodePrimitive
-(
- DecodePrimitive,
- bool,
- int8,
- text,
- bytea,
- timestamptz,
-)
-where
-
-import Hasql.Core.DecodePrimitive
diff --git a/library/Hasql/DecodeResult.hs b/library/Hasql/DecodeResult.hs
deleted file mode 100644
index 7320942..0000000
--- a/library/Hasql/DecodeResult.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-module Hasql.DecodeResult
-(
- DecodeResult,
- ignore,
- length,
- head,
- headIfExists,
- vector,
- list,
- revList,
- hashMap,
- foldRows,
- foldMRows,
-)
-where
-
-import Hasql.Core.DecodeResult
-
diff --git a/library/Hasql/DecodeRow.hs b/library/Hasql/DecodeRow.hs
deleted file mode 100644
index 5c86ebb..0000000
--- a/library/Hasql/DecodeRow.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Hasql.DecodeRow
-(
- DecodeRow,
- primitive,
- nullablePrimitive,
-)
-where
-
-import Hasql.Core.DecodeRow
-
diff --git a/library/Hasql/Decoders.hs b/library/Hasql/Decoders.hs
new file mode 100644
index 0000000..48294ea
--- /dev/null
+++ b/library/Hasql/Decoders.hs
@@ -0,0 +1,713 @@
+-- |
+-- A DSL for declaration of result decoders.
+module Hasql.Decoders
+(
+ -- * Result
+ Result,
+ unit,
+ rowsAffected,
+ singleRow,
+ -- ** Specialized multi-row results
+ maybeRow,
+ rowsVector,
+ rowsList,
+ -- ** Multi-row traversers
+ foldlRows,
+ foldrRows,
+ -- * Row
+ Row,
+ value,
+ nullableValue,
+ -- * Value
+ Value,
+ bool,
+ int2,
+ int4,
+ int8,
+ float4,
+ float8,
+ numeric,
+ char,
+ text,
+ bytea,
+ date,
+ timestamp,
+ timestamptz,
+ time,
+ timetz,
+ interval,
+ uuid,
+ inet,
+ json,
+ jsonBytes,
+ jsonb,
+ jsonbBytes,
+ array,
+ composite,
+ hstore,
+ enum,
+ custom,
+ -- * Array
+ Array,
+ arrayDimension,
+ arrayValue,
+ arrayNullableValue,
+ -- * Composite
+ Composite,
+ compositeValue,
+ compositeNullableValue,
+)
+where
+
+import Hasql.Private.Prelude hiding (maybe, bool)
+import qualified Data.Vector as Vector
+import qualified PostgreSQL.Binary.Decoding as A
+import qualified PostgreSQL.Binary.Data as B
+import qualified Hasql.Private.Decoders.Results as Results
+import qualified Hasql.Private.Decoders.Result as Result
+import qualified Hasql.Private.Decoders.Row as Row
+import qualified Hasql.Private.Decoders.Value as Value
+import qualified Hasql.Private.Decoders.Array as Array
+import qualified Hasql.Private.Decoders.Composite as Composite
+import qualified Hasql.Private.Prelude as Prelude
+
+-- * Result
+-------------------------
+
+-- |
+-- Decoder of a query result.
+--
+newtype Result a =
+ Result (Results.Results a)
+ deriving (Functor)
+
+-- |
+-- Decode no value from the result.
+--
+-- Useful for statements like @INSERT@ or @CREATE@.
+--
+{-# INLINABLE unit #-}
+unit :: Result ()
+unit =
+ Result (Results.single Result.unit)
+
+-- |
+-- Get the amount of rows affected by such statements as
+-- @UPDATE@ or @DELETE@.
+--
+{-# INLINABLE rowsAffected #-}
+rowsAffected :: Result Int64
+rowsAffected =
+ Result (Results.single Result.rowsAffected)
+
+-- |
+-- Exactly one row.
+-- Will raise the 'Hasql.Query.UnexpectedAmountOfRows' error if it's any other.
+--
+{-# INLINABLE singleRow #-}
+singleRow :: Row a -> Result a
+singleRow (Row row) =
+ Result (Results.single (Result.single row))
+
+-- ** Multi-row traversers
+-------------------------
+
+-- |
+-- Foldl multiple rows.
+--
+{-# INLINABLE foldlRows #-}
+foldlRows :: (a -> b -> a) -> a -> Row b -> Result a
+foldlRows step init (Row row) =
+ Result (Results.single (Result.foldl step init row))
+
+-- |
+-- Foldr multiple rows.
+--
+{-# INLINABLE foldrRows #-}
+foldrRows :: (b -> a -> a) -> a -> Row b -> Result a
+foldrRows step init (Row row) =
+ Result (Results.single (Result.foldr step init row))
+
+-- ** Specialized multi-row results
+-------------------------
+
+-- |
+-- Maybe one row or none.
+--
+{-# INLINABLE maybeRow #-}
+maybeRow :: Row a -> Result (Maybe a)
+maybeRow (Row row) =
+ Result (Results.single (Result.maybe row))
+
+-- |
+-- Zero or more rows packed into the vector.
+--
+-- It's recommended to prefer this function to 'rowsList',
+-- since it performs notably better.
+--
+{-# INLINABLE rowsVector #-}
+rowsVector :: Row a -> Result (Vector a)
+rowsVector (Row row) =
+ Result (Results.single (Result.vector row))
+
+-- |
+-- Zero or more rows packed into the list.
+--
+{-# INLINABLE rowsList #-}
+rowsList :: Row a -> Result [a]
+rowsList =
+ foldrRows strictCons []
+
+
+-- ** Instances
+-------------------------
+
+-- | Maps to 'unit'.
+instance Default (Result ()) where
+ {-# INLINE def #-}
+ def =
+ unit
+
+-- | Maps to 'rowsAffected'.
+instance Default (Result Int64) where
+ {-# INLINE def #-}
+ def =
+ rowsAffected
+
+-- | Maps to @('maybeRow' def)@.
+instance Default (Row a) => Default (Result (Maybe a)) where
+ {-# INLINE def #-}
+ def =
+ maybeRow def
+
+-- | Maps to @('rowsVector' def)@.
+instance Default (Row a) => Default (Result (Vector a)) where
+ {-# INLINE def #-}
+ def =
+ rowsVector def
+
+-- | Maps to @('rowsList' def)@.
+instance Default (Row a) => Default (Result ([] a)) where
+ {-# INLINE def #-}
+ def =
+ rowsList def
+
+-- | Maps to @(fmap Identity ('singleRow' def)@.
+instance Default (Row a) => Default (Result (Identity a)) where
+ {-# INLINE def #-}
+ def =
+ fmap Identity (singleRow def)
+
+
+-- * Row
+-------------------------
+
+-- |
+-- Decoder of an individual row,
+-- which gets composed of column value decoders.
+--
+-- E.g.:
+--
+-- >x :: Row (Maybe Int64, Text, TimeOfDay)
+-- >x =
+-- > (,,) <$> nullableValue int8 <*> value text <*> value time
+--
+newtype Row a =
+ Row (Row.Row a)
+ deriving (Functor, Applicative, Monad)
+
+-- |
+-- Lift an individual non-nullable value decoder to a composable row decoder.
+--
+{-# INLINABLE value #-}
+value :: Value a -> Row a
+value (Value imp) =
+ Row (Row.nonNullValue imp)
+
+-- |
+-- Lift an individual nullable value decoder to a composable row decoder.
+--
+{-# INLINABLE nullableValue #-}
+nullableValue :: Value a -> Row (Maybe a)
+nullableValue (Value imp) =
+ Row (Row.value imp)
+
+
+-- ** Instances
+-------------------------
+
+instance Default (Value a) => Default (Row (Identity a)) where
+ {-# INLINE def #-}
+ def =
+ fmap Identity (value def)
+
+instance Default (Value a) => Default (Row (Maybe a)) where
+ {-# INLINE def #-}
+ def =
+ nullableValue def
+
+instance (Default (Value a1), Default (Value a2)) => Default (Row (a1, a2)) where
+ {-# INLINE def #-}
+ def =
+ ap (fmap (,) (value def)) (value def)
+
+
+-- * Value
+-------------------------
+
+-- |
+-- Decoder of an individual value.
+--
+newtype Value a =
+ Value (Value.Value a)
+ deriving (Functor)
+
+
+-- ** Plain value decoders
+-------------------------
+
+-- |
+-- Decoder of the @BOOL@ values.
+--
+{-# INLINABLE bool #-}
+bool :: Value Bool
+bool =
+ Value (Value.decoder (const A.bool))
+
+-- |
+-- Decoder of the @INT2@ values.
+--
+{-# INLINABLE int2 #-}
+int2 :: Value Int16
+int2 =
+ Value (Value.decoder (const A.int))
+
+-- |
+-- Decoder of the @INT4@ values.
+--
+{-# INLINABLE int4 #-}
+int4 :: Value Int32
+int4 =
+ Value (Value.decoder (const A.int))
+
+-- |
+-- Decoder of the @INT8@ values.
+--
+{-# INLINABLE int8 #-}
+int8 :: Value Int64
+int8 =
+ {-# SCC "int8" #-}
+ Value (Value.decoder (const ({-# SCC "int8.int" #-} A.int)))
+
+-- |
+-- Decoder of the @FLOAT4@ values.
+--
+{-# INLINABLE float4 #-}
+float4 :: Value Float
+float4 =
+ Value (Value.decoder (const A.float4))
+
+-- |
+-- Decoder of the @FLOAT8@ values.
+--
+{-# INLINABLE float8 #-}
+float8 :: Value Double
+float8 =
+ Value (Value.decoder (const A.float8))
+
+-- |
+-- Decoder of the @NUMERIC@ values.
+--
+{-# INLINABLE numeric #-}
+numeric :: Value B.Scientific
+numeric =
+ Value (Value.decoder (const A.numeric))
+
+-- |
+-- Decoder of the @CHAR@ values.
+-- Note that it supports UTF-8 values.
+{-# INLINABLE char #-}
+char :: Value Char
+char =
+ Value (Value.decoder (const A.char))
+
+-- |
+-- Decoder of the @TEXT@ values.
+--
+{-# INLINABLE text #-}
+text :: Value Text
+text =
+ Value (Value.decoder (const A.text_strict))
+
+-- |
+-- Decoder of the @BYTEA@ values.
+--
+{-# INLINABLE bytea #-}
+bytea :: Value ByteString
+bytea =
+ Value (Value.decoder (const A.bytea_strict))
+
+-- |
+-- Decoder of the @DATE@ values.
+--
+{-# INLINABLE date #-}
+date :: Value B.Day
+date =
+ Value (Value.decoder (const A.date))
+
+-- |
+-- Decoder of the @TIMESTAMP@ values.
+--
+{-# INLINABLE timestamp #-}
+timestamp :: Value B.LocalTime
+timestamp =
+ Value (Value.decoder (Prelude.bool A.timestamp_float A.timestamp_int))
+
+-- |
+-- Decoder of the @TIMESTAMPTZ@ values.
+--
+-- /NOTICE/
+--
+-- Postgres does not store the timezone information of @TIMESTAMPTZ@.
+-- Instead it stores a UTC value and performs silent conversions
+-- to the currently set timezone, when dealt with in the text format.
+-- However this library bypasses the silent conversions
+-- and communicates with Postgres using the UTC values directly.
+{-# INLINABLE timestamptz #-}
+timestamptz :: Value B.UTCTime
+timestamptz =
+ Value (Value.decoder (Prelude.bool A.timestamptz_float A.timestamptz_int))
+
+-- |
+-- Decoder of the @TIME@ values.
+--
+{-# INLINABLE time #-}
+time :: Value B.TimeOfDay
+time =
+ Value (Value.decoder (Prelude.bool A.time_float A.time_int))
+
+-- |
+-- Decoder of the @TIMETZ@ values.
+--
+-- Unlike in case of @TIMESTAMPTZ@,
+-- Postgres does store the timezone information for @TIMETZ@.
+-- However the Haskell's \"time\" library does not contain any composite type,
+-- that fits the task, so we use a pair of 'TimeOfDay' and 'TimeZone'
+-- to represent a value on the Haskell's side.
+{-# INLINABLE timetz #-}
+timetz :: Value (B.TimeOfDay, B.TimeZone)
+timetz =
+ Value (Value.decoder (Prelude.bool A.timetz_float A.timetz_int))
+
+-- |
+-- Decoder of the @INTERVAL@ values.
+--
+{-# INLINABLE interval #-}
+interval :: Value B.DiffTime
+interval =
+ Value (Value.decoder (Prelude.bool A.interval_float A.interval_int))
+
+-- |
+-- Decoder of the @UUID@ values.
+--
+{-# INLINABLE uuid #-}
+uuid :: Value B.UUID
+uuid =
+ Value (Value.decoder (const A.uuid))
+
+-- |
+-- Decoder of the @INET@ values.
+--
+{-# INLINABLE inet #-}
+inet :: Value (B.NetAddr B.IP)
+inet =
+ Value (Value.decoder (const A.inet))
+
+-- |
+-- Decoder of the @JSON@ values into a JSON AST.
+--
+{-# INLINABLE json #-}
+json :: Value B.Value
+json =
+ Value (Value.decoder (const A.json_ast))
+
+-- |
+-- Decoder of the @JSON@ values into a raw JSON 'ByteString'.
+--
+{-# INLINABLE jsonBytes #-}
+jsonBytes :: (ByteString -> Either Text a) -> Value a
+jsonBytes fn =
+ Value (Value.decoder (const (A.json_bytes fn)))
+
+-- |
+-- Decoder of the @JSONB@ values into a JSON AST.
+--
+{-# INLINABLE jsonb #-}
+jsonb :: Value B.Value
+jsonb =
+ Value (Value.decoder (const A.jsonb_ast))
+
+-- |
+-- Decoder of the @JSONB@ values into a raw JSON 'ByteString'.
+--
+{-# INLINABLE jsonbBytes #-}
+jsonbBytes :: (ByteString -> Either Text a) -> Value a
+jsonbBytes fn =
+ Value (Value.decoder (const (A.jsonb_bytes fn)))
+
+-- |
+-- Lifts a custom value decoder function to a 'Value' decoder.
+--
+{-# INLINABLE custom #-}
+custom :: (Bool -> ByteString -> Either Text a) -> Value a
+custom fn =
+ Value (Value.decoderFn fn)
+
+
+-- ** Composite value decoders
+-------------------------
+
+-- |
+-- Lifts the 'Array' decoder to the 'Value' decoder.
+--
+{-# INLINABLE array #-}
+array :: Array a -> Value a
+array (Array imp) =
+ Value (Value.decoder (Array.run imp))
+
+-- |
+-- Lifts the 'Composite' decoder to the 'Value' decoder.
+--
+{-# INLINABLE composite #-}
+composite :: Composite a -> Value a
+composite (Composite imp) =
+ Value (Value.decoder (Composite.run imp))
+
+-- |
+-- A generic decoder of @HSTORE@ values.
+--
+-- Here's how you can use it to construct a specific value:
+--
+-- @
+-- x :: Value [(Text, Maybe Text)]
+-- x =
+-- hstore 'replicateM'
+-- @
+--
+{-# INLINABLE hstore #-}
+hstore :: (forall m. Monad m => Int -> m (Text, Maybe Text) -> m a) -> Value a
+hstore replicateM =
+ Value (Value.decoder (const (A.hstore replicateM A.text_strict A.text_strict)))
+
+-- |
+-- Given a partial mapping from text to value,
+-- produces a decoder of that value.
+enum :: (Text -> Maybe a) -> Value a
+enum mapping =
+ Value (Value.decoder (const (A.enum mapping)))
+
+
+-- ** Instances
+-------------------------
+
+-- |
+-- Maps to 'bool'.
+instance Default (Value Bool) where
+ {-# INLINE def #-}
+ def =
+ bool
+
+-- |
+-- Maps to 'int2'.
+instance Default (Value Int16) where
+ {-# INLINE def #-}
+ def =
+ int2
+
+-- |
+-- Maps to 'int4'.
+instance Default (Value Int32) where
+ {-# INLINE def #-}
+ def =
+ int4
+
+-- |
+-- Maps to 'int8'.
+instance Default (Value Int64) where
+ {-# INLINE def #-}
+ def =
+ int8
+
+-- |
+-- Maps to 'float4'.
+instance Default (Value Float) where
+ {-# INLINE def #-}
+ def =
+ float4
+
+-- |
+-- Maps to 'float8'.
+instance Default (Value Double) where
+ {-# INLINE def #-}
+ def =
+ float8
+
+-- |
+-- Maps to 'numeric'.
+instance Default (Value B.Scientific) where
+ {-# INLINE def #-}
+ def =
+ numeric
+
+-- |
+-- Maps to 'char'.
+instance Default (Value Char) where
+ {-# INLINE def #-}
+ def =
+ char
+
+-- |
+-- Maps to 'text'.
+instance Default (Value Text) where
+ {-# INLINE def #-}
+ def =
+ text
+
+-- |
+-- Maps to 'bytea'.
+instance Default (Value ByteString) where
+ {-# INLINE def #-}
+ def =
+ bytea
+
+-- |
+-- Maps to 'date'.
+instance Default (Value B.Day) where
+ {-# INLINE def #-}
+ def =
+ date
+
+-- |
+-- Maps to 'timestamp'.
+instance Default (Value B.LocalTime) where
+ {-# INLINE def #-}
+ def =
+ timestamp
+
+-- |
+-- Maps to 'timestamptz'.
+instance Default (Value B.UTCTime) where
+ {-# INLINE def #-}
+ def =
+ timestamptz
+
+-- |
+-- Maps to 'time'.
+instance Default (Value B.TimeOfDay) where
+ {-# INLINE def #-}
+ def =
+ time
+
+-- |
+-- Maps to 'timetz'.
+instance Default (Value (B.TimeOfDay, B.TimeZone)) where
+ {-# INLINE def #-}
+ def =
+ timetz
+
+-- |
+-- Maps to 'interval'.
+instance Default (Value B.DiffTime) where
+ {-# INLINE def #-}
+ def =
+ interval
+
+-- |
+-- Maps to 'uuid'.
+instance Default (Value B.UUID) where
+ {-# INLINE def #-}
+ def =
+ uuid
+
+-- |
+-- Maps to 'json'.
+instance Default (Value B.Value) where
+ {-# INLINE def #-}
+ def =
+ json
+
+
+-- * Array decoders
+-------------------------
+
+-- |
+-- A generic array decoder.
+--
+-- Here's how you can use it to produce a specific array value decoder:
+--
+-- @
+-- x :: Value [[Text]]
+-- x =
+-- array (arrayDimension 'replicateM' (arrayDimension 'replicateM' (arrayValue 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 'arrayDimension',
+-- 'arrayValue' or 'arrayNullableValue'.
+--
+{-# INLINABLE arrayDimension #-}
+arrayDimension :: (forall m. Monad m => Int -> m a -> m b) -> Array a -> Array b
+arrayDimension replicateM (Array imp) =
+ Array (Array.dimension replicateM imp)
+
+-- |
+-- Lift a 'Value' decoder into an 'Array' decoder for parsing of non-nullable leaf values.
+{-# INLINABLE arrayValue #-}
+arrayValue :: Value a -> Array a
+arrayValue (Value imp) =
+ Array (Array.nonNullValue (Value.run imp))
+
+-- |
+-- Lift a 'Value' decoder into an 'Array' decoder for parsing of nullable leaf values.
+{-# INLINABLE arrayNullableValue #-}
+arrayNullableValue :: Value a -> Array (Maybe a)
+arrayNullableValue (Value imp) =
+ Array (Array.value (Value.run imp))
+
+
+-- * Composite decoders
+-------------------------
+
+-- |
+-- Composable decoder of composite values (rows, records).
+newtype Composite a =
+ Composite (Composite.Composite a)
+ deriving (Functor, Applicative, Monad)
+
+-- |
+-- Lift a 'Value' decoder into a 'Composite' decoder for parsing of non-nullable leaf values.
+{-# INLINABLE compositeValue #-}
+compositeValue :: Value a -> Composite a
+compositeValue (Value imp) =
+ Composite (Composite.nonNullValue (Value.run imp))
+
+-- |
+-- Lift a 'Value' decoder into a 'Composite' decoder for parsing of nullable leaf values.
+{-# INLINABLE compositeNullableValue #-}
+compositeNullableValue :: Value a -> Composite (Maybe a)
+compositeNullableValue (Value imp) =
+ Composite (Composite.value (Value.run imp))
+
diff --git a/library/Hasql/EncodeParam.hs b/library/Hasql/EncodeParam.hs
deleted file mode 100644
index c84f479..0000000
--- a/library/Hasql/EncodeParam.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Hasql.EncodeParam
-(
- EncodeParam,
- primitive,
- arrayVector,
- arrayVectorWithNulls,
-)
-where
-
-import Hasql.Core.EncodeParam
diff --git a/library/Hasql/EncodeParams.hs b/library/Hasql/EncodeParams.hs
deleted file mode 100644
index 7ba0002..0000000
--- a/library/Hasql/EncodeParams.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module Hasql.EncodeParams
-(
- EncodeParams,
- param,
- nullableParam,
-)
-where
-
-import Hasql.Core.EncodeParams
diff --git a/library/Hasql/EncodePrimitive.hs b/library/Hasql/EncodePrimitive.hs
deleted file mode 100644
index 79a427d..0000000
--- a/library/Hasql/EncodePrimitive.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-module Hasql.EncodePrimitive
-(
- EncodePrimitive,
- int2,
- int4,
- int8,
- text,
- date,
- time,
- timetz,
- timestamp,
- timestamptz,
- interval,
-)
-where
-
-import Hasql.Core.EncodePrimitive
diff --git a/library/Hasql/Encoders.hs b/library/Hasql/Encoders.hs
new file mode 100644
index 0000000..95a19cf
--- /dev/null
+++ b/library/Hasql/Encoders.hs
@@ -0,0 +1,560 @@
+-- |
+-- A DSL for declaration of query parameter encoders.
+module Hasql.Encoders
+(
+ -- * Params
+ Params,
+ unit,
+ value,
+ nullableValue,
+ -- * Value
+ Value,
+ bool,
+ int2,
+ int4,
+ int8,
+ float4,
+ float8,
+ numeric,
+ char,
+ text,
+ bytea,
+ date,
+ timestamp,
+ timestamptz,
+ time,
+ timetz,
+ interval,
+ uuid,
+ inet,
+ json,
+ jsonBytes,
+ jsonb,
+ jsonbBytes,
+ array,
+ enum,
+ unknown,
+ -- * Array
+ Array,
+ arrayValue,
+ arrayNullableValue,
+ arrayDimension,
+ -- ** Insert Many
+ -- $insertMany
+)
+where
+
+import Hasql.Private.Prelude hiding (bool)
+import qualified PostgreSQL.Binary.Encoding as A
+import qualified PostgreSQL.Binary.Data as B
+import qualified Hasql.Private.Encoders.Params as Params
+import qualified Hasql.Private.Encoders.Value as Value
+import qualified Hasql.Private.Encoders.Array as Array
+import qualified Hasql.Private.PTI as PTI
+import qualified Hasql.Private.Prelude as Prelude
+
+-- * Parameters Product Encoder
+-------------------------
+
+-- |
+-- Encoder of some representation of the parameters product.
+--
+-- Has instances of 'Contravariant', 'Divisible' and 'Monoid',
+-- which you can use to compose multiple parameters together.
+-- E.g.,
+--
+-- @
+-- someParamsEncoder :: 'Params' (Int64, Maybe Text)
+-- someParamsEncoder =
+-- 'contramap' 'fst' ('value' 'int8') '<>'
+-- 'contramap' 'snd' ('nullableValue' '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' ('value' 'int8') ('nullableValue' 'text')
+-- @
+--
+-- Here's how you can implement encoders for custom composite types:
+--
+-- @
+-- data Person =
+-- Person { name :: Text, gender :: Gender, age :: Int }
+--
+-- data Gender =
+-- Male | Female
+--
+-- personParams :: 'Params' Person
+-- personParams =
+-- 'contramap' name ('value' 'text') '<>'
+-- 'contramap' gender ('value' genderValue) '<>'
+-- 'contramap' (fromIntegral . age) ('value' 'int8')
+--
+-- genderValue :: 'Value' Gender
+-- genderValue =
+-- 'contramap' genderText 'text'
+-- where
+-- genderText gender =
+-- case gender of
+-- Male -> "male"
+-- Female -> "female"
+-- @
+--
+newtype Params a =
+ Params (Params.Params a)
+ deriving (Contravariant, Divisible, Decidable, Monoid, Semigroup)
+
+-- |
+-- Encode no parameters.
+--
+{-# INLINABLE unit #-}
+unit :: Params ()
+unit =
+ Params mempty
+
+-- |
+-- Lift an individual value encoder to a parameters encoder.
+--
+{-# INLINABLE value #-}
+value :: Value a -> Params a
+value (Value x) =
+ Params (Params.value x)
+
+-- |
+-- Lift an individual nullable value encoder to a parameters encoder.
+--
+{-# INLINABLE nullableValue #-}
+nullableValue :: Value a -> Params (Maybe a)
+nullableValue (Value x) =
+ Params (Params.nullableValue x)
+
+
+-- ** Instances
+-------------------------
+
+-- |
+-- Maps to 'unit'.
+instance Default (Params ()) where
+ {-# INLINE def #-}
+ def =
+ unit
+
+instance Default (Value a) => Default (Params (Identity a)) where
+ {-# INLINE def #-}
+ def =
+ contramap runIdentity (value def)
+
+instance (Default (Value a1), Default (Value a2)) => Default (Params (a1, a2)) where
+ {-# INLINE def #-}
+ def =
+ contrazip2 (value def) (value def)
+
+instance (Default (Value a1), Default (Value a2), Default (Value a3)) => Default (Params (a1, a2, a3)) where
+ {-# INLINE def #-}
+ def =
+ contrazip3 (value def) (value def) (value def)
+
+instance (Default (Value a1), Default (Value a2), Default (Value a3), Default (Value a4)) => Default (Params (a1, a2, a3, a4)) where
+ {-# INLINE def #-}
+ def =
+ contrazip4 (value def) (value def) (value def) (value def)
+
+instance (Default (Value a1), Default (Value a2), Default (Value a3), Default (Value a4), Default (Value a5)) => Default (Params (a1, a2, a3, a4, a5)) where
+ {-# INLINE def #-}
+ def =
+ contrazip5 (value def) (value def) (value def) (value def) (value def)
+
+
+-- * Value Encoder
+-------------------------
+
+-- |
+-- An individual value encoder.
+-- Will be mapped to a single placeholder in the query.
+--
+newtype Value a =
+ Value (Value.Value a)
+ deriving (Contravariant)
+
+-- |
+-- Encoder of @BOOL@ values.
+{-# INLINABLE bool #-}
+bool :: Value Bool
+bool =
+ Value (Value.unsafePTI PTI.bool (const A.bool))
+
+-- |
+-- Encoder of @INT2@ values.
+{-# INLINABLE int2 #-}
+int2 :: Value Int16
+int2 =
+ Value (Value.unsafePTI PTI.int2 (const A.int2_int16))
+
+-- |
+-- Encoder of @INT4@ values.
+{-# INLINABLE int4 #-}
+int4 :: Value Int32
+int4 =
+ Value (Value.unsafePTI PTI.int4 (const A.int4_int32))
+
+-- |
+-- Encoder of @INT8@ values.
+{-# INLINABLE int8 #-}
+int8 :: Value Int64
+int8 =
+ Value (Value.unsafePTI PTI.int8 (const A.int8_int64))
+
+-- |
+-- Encoder of @FLOAT4@ values.
+{-# INLINABLE float4 #-}
+float4 :: Value Float
+float4 =
+ Value (Value.unsafePTI PTI.float4 (const A.float4))
+
+-- |
+-- Encoder of @FLOAT8@ values.
+{-# INLINABLE float8 #-}
+float8 :: Value Double
+float8 =
+ Value (Value.unsafePTI PTI.float8 (const A.float8))
+
+-- |
+-- Encoder of @NUMERIC@ values.
+{-# INLINABLE numeric #-}
+numeric :: Value B.Scientific
+numeric =
+ Value (Value.unsafePTI PTI.numeric (const A.numeric))
+
+-- |
+-- Encoder of @CHAR@ values.
+-- Note that it supports UTF-8 values and
+-- identifies itself under the @TEXT@ OID because of that.
+{-# INLINABLE char #-}
+char :: Value Char
+char =
+ Value (Value.unsafePTI PTI.text (const A.char_utf8))
+
+-- |
+-- Encoder of @TEXT@ values.
+{-# INLINABLE text #-}
+text :: Value Text
+text =
+ Value (Value.unsafePTI PTI.text (const A.text_strict))
+
+-- |
+-- Encoder of @BYTEA@ values.
+{-# INLINABLE bytea #-}
+bytea :: Value ByteString
+bytea =
+ Value (Value.unsafePTI PTI.bytea (const A.bytea_strict))
+
+-- |
+-- Encoder of @DATE@ values.
+{-# INLINABLE date #-}
+date :: Value B.Day
+date =
+ Value (Value.unsafePTI PTI.date (const A.date))
+
+-- |
+-- Encoder of @TIMESTAMP@ values.
+{-# INLINABLE timestamp #-}
+timestamp :: Value B.LocalTime
+timestamp =
+ Value (Value.unsafePTI PTI.timestamp (Prelude.bool A.timestamp_float A.timestamp_int))
+
+-- |
+-- Encoder of @TIMESTAMPTZ@ values.
+{-# INLINABLE timestamptz #-}
+timestamptz :: Value B.UTCTime
+timestamptz =
+ Value (Value.unsafePTI PTI.timestamptz (Prelude.bool A.timestamptz_float A.timestamptz_int))
+
+-- |
+-- Encoder of @TIME@ values.
+{-# INLINABLE time #-}
+time :: Value B.TimeOfDay
+time =
+ Value (Value.unsafePTI PTI.time (Prelude.bool A.time_float A.time_int))
+
+-- |
+-- Encoder of @TIMETZ@ values.
+{-# INLINABLE timetz #-}
+timetz :: Value (B.TimeOfDay, B.TimeZone)
+timetz =
+ Value (Value.unsafePTI PTI.timetz (Prelude.bool A.timetz_float A.timetz_int))
+
+-- |
+-- Encoder of @INTERVAL@ values.
+{-# INLINABLE interval #-}
+interval :: Value B.DiffTime
+interval =
+ Value (Value.unsafePTI PTI.interval (Prelude.bool A.interval_float A.interval_int))
+
+-- |
+-- Encoder of @UUID@ values.
+{-# INLINABLE uuid #-}
+uuid :: Value B.UUID
+uuid =
+ Value (Value.unsafePTI PTI.uuid (const A.uuid))
+
+-- |
+-- Encoder of @INET@ values.
+{-# INLINABLE inet #-}
+inet :: Value (B.NetAddr B.IP)
+inet =
+ Value (Value.unsafePTI PTI.inet (const A.inet))
+
+-- |
+-- Encoder of @JSON@ values from JSON AST.
+{-# INLINABLE json #-}
+json :: Value B.Value
+json =
+ Value (Value.unsafePTI PTI.json (const A.json_ast))
+
+-- |
+-- Encoder of @JSON@ values from raw JSON.
+{-# INLINABLE jsonBytes #-}
+jsonBytes :: Value ByteString
+jsonBytes =
+ Value (Value.unsafePTI PTI.json (const A.json_bytes))
+
+-- |
+-- Encoder of @JSONB@ values from JSON AST.
+{-# INLINABLE jsonb #-}
+jsonb :: Value B.Value
+jsonb =
+ Value (Value.unsafePTI PTI.jsonb (const A.jsonb_ast))
+
+-- |
+-- Encoder of @JSONB@ values from raw JSON.
+{-# INLINABLE jsonbBytes #-}
+jsonbBytes :: Value ByteString
+jsonbBytes =
+ Value (Value.unsafePTI PTI.jsonb (const A.jsonb_bytes))
+
+-- |
+-- Unlifts the 'Array' encoder to the plain 'Value' encoder.
+{-# INLINABLE array #-}
+array :: Array a -> Value a
+array (Array imp) =
+ Array.run imp & \(arrayOID, encoder') ->
+ Value (Value.Value arrayOID arrayOID encoder')
+
+-- |
+-- Given a function,
+-- which maps the value into the textual enum label from the DB side,
+-- produces a encoder of that value.
+{-# INLINABLE enum #-}
+enum :: (a -> Text) -> Value a
+enum mapping =
+ Value (Value.unsafePTI PTI.text (const (A.text_strict . mapping)))
+
+-- |
+-- Identifies the value with the PostgreSQL's \"unknown\" type,
+-- thus leaving it up to Postgres to infer the actual type of the value.
+--
+-- The bytestring needs to be encoded according to the Postgres\' binary format
+-- of the type it expects.
+--
+-- Essentially this is a low-level hook for encoding of values with custom codecs.
+-- The
+-- <http://hackage.haskell.org/package/postgresql-binary "postgresql-binary">
+-- library will provide you with the toolchain.
+--
+{-# INLINABLE unknown #-}
+unknown :: Value ByteString
+unknown =
+ Value (Value.unsafePTI PTI.unknown (const A.bytea_strict))
+
+
+-- ** Instances
+-------------------------
+
+-- | Maps to 'bool'.
+instance Default (Value Bool) where
+ {-# INLINE def #-}
+ def =
+ bool
+
+-- | Maps to 'int2'.
+instance Default (Value Int16) where
+ {-# INLINE def #-}
+ def =
+ int2
+
+-- | Maps to 'int4'.
+instance Default (Value Int32) where
+ {-# INLINE def #-}
+ def =
+ int4
+
+-- | Maps to 'int8'.
+instance Default (Value Int64) where
+ {-# INLINE def #-}
+ def =
+ int8
+
+-- | Maps to 'float4'.
+instance Default (Value Float) where
+ {-# INLINE def #-}
+ def =
+ float4
+
+-- | Maps to 'float8'.
+instance Default (Value Double) where
+ {-# INLINE def #-}
+ def =
+ float8
+
+-- | Maps to 'numeric'.
+instance Default (Value B.Scientific) where
+ {-# INLINE def #-}
+ def =
+ numeric
+
+-- | Maps to 'char'.
+instance Default (Value Char) where
+ {-# INLINE def #-}
+ def =
+ char
+
+-- | Maps to 'text'.
+instance Default (Value Text) where
+ {-# INLINE def #-}
+ def =
+ text
+
+-- | Maps to 'bytea'.
+instance Default (Value ByteString) where
+ {-# INLINE def #-}
+ def =
+ bytea
+
+-- | Maps to 'date'.
+instance Default (Value B.Day) where
+ {-# INLINE def #-}
+ def =
+ date
+
+-- | Maps to 'timestamp'.
+instance Default (Value B.LocalTime) where
+ {-# INLINE def #-}
+ def =
+ timestamp
+
+-- | Maps to 'timestamptz'.
+instance Default (Value B.UTCTime) where
+ {-# INLINE def #-}
+ def =
+ timestamptz
+
+-- | Maps to 'time'.
+instance Default (Value B.TimeOfDay) where
+ {-# INLINE def #-}
+ def =
+ time
+
+-- | Maps to 'timetz'.
+instance Default (Value (B.TimeOfDay, B.TimeZone)) where
+ {-# INLINE def #-}
+ def =
+ timetz
+
+-- | Maps to 'interval'.
+instance Default (Value B.DiffTime) where
+ {-# INLINE def #-}
+ def =
+ interval
+
+-- | Maps to 'uuid'.
+instance Default (Value B.UUID) where
+ {-# INLINE def #-}
+ def =
+ uuid
+
+-- | Maps to 'json'.
+instance Default (Value B.Value) where
+ {-# INLINE def #-}
+ def =
+ json
+
+
+-- * Array
+-------------------------
+
+-- |
+-- A generic array encoder.
+--
+-- Here's an example of its usage:
+--
+-- >x :: Value [[Int64]]
+-- >x =
+-- > array (arrayDimension foldl' (arrayDimension foldl' (arrayValue int8)))
+--
+-- Please note that the PostgreSQL __IN__ keyword does not "accept" an array, but rather a syntactical list of
+-- values, thus this encoder is not suited for that. Use a **field** = ANY($1) query instead.
+--
+newtype Array a =
+ Array (Array.Array a)
+
+-- |
+-- Lifts the 'Value' encoder into the 'Array' encoder of a non-nullable value.
+{-# INLINABLE arrayValue #-}
+arrayValue :: Value a -> Array a
+arrayValue (Value (Value.Value elementOID arrayOID encoder')) =
+ Array (Array.value elementOID arrayOID encoder')
+
+-- |
+-- Lifts the 'Value' encoder into the 'Array' encoder of a nullable value.
+{-# INLINABLE arrayNullableValue #-}
+arrayNullableValue :: Value a -> Array (Maybe a)
+arrayNullableValue (Value (Value.Value elementOID arrayOID encoder')) =
+ Array (Array.nullableValue elementOID arrayOID encoder')
+
+-- |
+-- An encoder of an array dimension,
+-- which thus provides support for multidimensional arrays.
+--
+-- Accepts:
+--
+-- * An implementation of the left-fold operation,
+-- such as @Data.Foldable.'foldl''@,
+-- which determines the input value.
+--
+-- * A component encoder, which can be either another 'arrayDimension',
+-- 'arrayValue' or 'arrayNullableValue'.
+--
+{-# INLINABLE arrayDimension #-}
+arrayDimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c
+arrayDimension foldl (Array imp) =
+ Array (Array.dimension foldl imp)
+
+-- $insertMany
+-- It is not currently possible to pass in an array of encodable values
+-- to use in an 'insert many' query using Hasql. Instead, PostgreSQL's
+-- (9.4 or later) `unnest` function can be used to in an analogous way
+-- to haskell's `zip` function by passing in multiple arrays of values
+-- to be zipped into the rows we want to insert:
+--
+-- @
+-- insertMultipleLocations :: Query (Vector (UUID, Double, Double)) ()
+-- insertMultipleLocations =
+-- statement sql encoder decoder True
+-- where
+-- sql =
+-- "insert into location (id, x, y) select * from unnest ($1, $2, $3)"
+-- encoder =
+-- contramap Vector.unzip3 $
+-- contrazip3 (vector Encoders.uuid) (vector Encoders.float8) (vector Encoders.float8)
+-- where
+-- vector value =
+-- Encoders.value (Encoders.array (Encoders.arrayDimension foldl' (Encoders.arrayValue value)))
+-- decoder =
+-- Decoders.unit
+-- @ \ No newline at end of file
diff --git a/library/Hasql/Prelude.hs b/library/Hasql/Prelude.hs
deleted file mode 100644
index cb52c43..0000000
--- a/library/Hasql/Prelude.hs
+++ /dev/null
@@ -1,207 +0,0 @@
-module Hasql.Prelude
-(
- module Exports,
- forMToZero_,
- forMFromZero_,
- strictCons,
- regions,
- match,
- traceEventIO,
- traceEvent,
- traceMarkerIO,
- traceMarker,
- startThread,
- startThreads,
- ErrorWithContext(..),
-)
-where
-
-
--- base-prelude
--------------------------
-import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, (<>), First(..), Last(..), ProtocolError, traceEvent, traceEventIO, traceMarker, traceMarkerIO)
-
--- transformers
--------------------------
-import Control.Monad.IO.Class as Exports
-import Control.Monad.Trans.Class as Exports
-import Control.Monad.Trans.Cont as Exports hiding (shift, callCC)
-import Control.Monad.Trans.Except as Exports (ExceptT(ExceptT), Except, except, runExcept, runExceptT, mapExcept, mapExceptT, withExcept, withExceptT, throwE, catchE)
-import Control.Monad.Trans.Maybe as Exports
-import Control.Monad.Trans.Reader as Exports (Reader, runReader, mapReader, withReader, ReaderT(ReaderT), runReaderT, mapReaderT, withReaderT)
-import Control.Monad.Trans.State.Strict as Exports (State, runState, evalState, execState, mapState, withState, StateT(StateT), runStateT, evalStateT, execStateT, mapStateT, withStateT)
-import Control.Monad.Trans.Writer.Strict as Exports (Writer, runWriter, execWriter, mapWriter, WriterT(..), execWriterT, mapWriterT)
-import Data.Functor.Compose as Exports
-
--- mtl
--------------------------
-import Control.Monad.Cont.Class as Exports
-import Control.Monad.Error.Class as Exports hiding (Error(..))
-import Control.Monad.Reader.Class as Exports
-import Control.Monad.State.Class as Exports
-import Control.Monad.Writer.Class as Exports
-
--- contravariant
--------------------------
-import Data.Functor.Contravariant as Exports
-import Data.Functor.Contravariant.Divisible as Exports
-
--- profunctors
--------------------------
-import Data.Profunctor.Unsafe as Exports
-
--- semigroups
--------------------------
-import Data.Semigroup as Exports
-
--- foldl
--------------------------
-import Control.Foldl as Exports (Fold(..), FoldM(..))
-
--- free
--------------------------
-import Control.Monad.Free.Church as Exports
-
--- stm
--------------------------
-import Control.Concurrent.STM as Exports
-
--- hashable
--------------------------
-import Data.Hashable as Exports (Hashable(..))
-
--- text
--------------------------
-import Data.Text as Exports (Text)
-
--- bytestring
--------------------------
-import Data.ByteString as Exports (ByteString)
-
--- vector
--------------------------
-import Data.Vector as Exports (Vector)
-
--- containers
--------------------------
-import Data.IntMap.Strict as Exports (IntMap)
-import Data.IntSet as Exports (IntSet)
-import Data.Map.Strict as Exports (Map)
-import Data.Sequence as Exports (Seq)
-import Data.Set as Exports (Set)
-
--- unordered-containers
--------------------------
-import Data.HashSet as Exports (HashSet)
-import Data.HashMap.Strict as Exports (HashMap)
-
--- dlist
--------------------------
-import Data.DList as Exports (DList)
-
--- time
--------------------------
-import Data.Time as Exports
-
--- bug
--------------------------
-import Bug as Exports
-
---
--------------------------
-
-import qualified GHC.RTS.Flags as A
-import qualified BasePrelude as B
-
-
--- * Workarounds for unremoved event logging
--------------------------
-
-{-# NOINLINE matchTraceUserEvents #-}
-matchTraceUserEvents :: a -> a -> a
-matchTraceUserEvents =
- case A.user (unsafeDupablePerformIO A.getTraceFlags) of
- True -> \_ x -> x
- False -> \x _ -> x
-
-{-# NOINLINE traceEventIO #-}
-traceEventIO =
- matchTraceUserEvents (const (return ())) B.traceEventIO
-
-{-# NOINLINE traceEvent #-}
-traceEvent =
- matchTraceUserEvents (const id) B.traceEvent
-
-{-# NOINLINE traceMarkerIO #-}
-traceMarkerIO =
- matchTraceUserEvents (const (return ())) B.traceMarkerIO
-
-{-# NOINLINE traceMarker #-}
-traceMarker =
- matchTraceUserEvents (const id) B.traceMarker
-
-{-# 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
-
-{-|
-An integer space distributed maximally evenly across regions.
--}
-regions :: Int -> Int -> [(Int, Int)]
-regions maxRegions space =
- case divMod space maxRegions of
- (baseSize, remainingSpace) ->
- build [] maxRegions space remainingSpace
- where
- build state regionsState spaceState remainingSpaceState =
- if remainingSpaceState > 0
- then
- addRegion (succ baseSize) (pred remainingSpaceState)
- else
- if regionsState > 0 && baseSize > 0
- then
- addRegion baseSize remainingSpaceState
- else
- state
- where
- addRegion regionSize remainingSpaceState =
- build (region : state) (pred regionsState) regionStart remainingSpaceState
- where
- !region =
- (regionStart, spaceState)
- !regionStart =
- spaceState - regionSize
-
-match :: output -> [(input -> Bool, output)] -> input -> output
-match defaultOutput cases =
- case cases of
- (predicate, output) : casesTail -> \input ->
- if predicate input
- then output
- else match defaultOutput casesTail input
- _ -> const defaultOutput
-
-{-# INLINE startThread #-}
-startThread :: IO () -> IO (IO ())
-startThread action =
- fmap killThread (forkIO action)
-
-{-# INLINE startThreads #-}
-startThreads :: [IO ()] -> IO (IO ())
-startThreads =
- fmap sequence_ . traverse startThread
-
-data ErrorWithContext =
- ContextErrorWithContext !Text !ErrorWithContext |
- MessageErrorWithContext !Text
diff --git a/library/Hasql/Private/Commands.hs b/library/Hasql/Private/Commands.hs
new file mode 100644
index 0000000..602fbd4
--- /dev/null
+++ b/library/Hasql/Private/Commands.hs
@@ -0,0 +1,33 @@
+module Hasql.Private.Commands
+(
+ Commands,
+ asBytes,
+ setEncodersToUTF8,
+ setMinClientMessagesToWarning,
+)
+where
+
+import Hasql.Private.Prelude
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy.Builder as BB
+import qualified Data.ByteString.Lazy.Builder.ASCII as BB
+import qualified Data.ByteString.Lazy as BL
+
+
+newtype Commands =
+ Commands (DList BB.Builder)
+ deriving (Monoid)
+
+instance Semigroup Commands
+
+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")
diff --git a/library/Hasql/Private/Connection.hs b/library/Hasql/Private/Connection.hs
new file mode 100644
index 0000000..86d2e5a
--- /dev/null
+++ b/library/Hasql/Private/Connection.hs
@@ -0,0 +1,52 @@
+-- |
+-- This module provides a low-level effectful API dealing with the connections to the database.
+module Hasql.Private.Connection
+where
+
+import Hasql.Private.Prelude
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified Hasql.Private.PreparedStatementRegistry as PreparedStatementRegistry
+import qualified Hasql.Private.IO as IO
+import 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" #-}
+ runEitherT $ do
+ pqConnection <- lift (IO.acquireConnection settings)
+ lift (IO.checkConnectionStatus pqConnection) >>= traverse left
+ 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
diff --git a/library/Hasql/Private/Decoders/Array.hs b/library/Hasql/Private/Decoders/Array.hs
new file mode 100644
index 0000000..01c5b32
--- /dev/null
+++ b/library/Hasql/Private/Decoders/Array.hs
@@ -0,0 +1,30 @@
+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'
+
diff --git a/library/Hasql/Private/Decoders/Composite.hs b/library/Hasql/Private/Decoders/Composite.hs
new file mode 100644
index 0000000..3bebc90
--- /dev/null
+++ b/library/Hasql/Private/Decoders/Composite.hs
@@ -0,0 +1,25 @@
+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)
+
+{-# 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'
+
diff --git a/library/Hasql/Private/Decoders/Result.hs b/library/Hasql/Private/Decoders/Result.hs
new file mode 100644
index 0000000..f4ae9c6
--- /dev/null
+++ b/library/Hasql/Private/Decoders/Result.hs
@@ -0,0 +1,232 @@
+module Hasql.Private.Decoders.Result where
+
+import Hasql.Private.Prelude hiding (maybe, many)
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified Hasql.Private.Decoders.Row as Row
+import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec
+import qualified Data.ByteString as ByteString
+import qualified Hasql.Private.Prelude as Prelude
+import qualified Data.Vector as Vector
+import qualified Data.Vector.Mutable as MutableVector
+
+
+newtype Result a =
+ Result (ReaderT (Bool, LibPQ.Result) (EitherT Error IO) a)
+ deriving (Functor, Applicative, Monad)
+
+data Error =
+ -- |
+ -- An error reported by the DB. Code, message, details, hint.
+ --
+ -- * The SQLSTATE code for the error. The SQLSTATE code identifies the type of error that has occurred;
+ -- it can be used by front-end applications to perform specific operations (such as error handling)
+ -- in response to a particular database error.
+ -- For a list of the possible SQLSTATE codes, see Appendix A.
+ -- This field is not localizable, and is always present.
+ --
+ -- * The primary human-readable error message (typically one line). Always present.
+ --
+ -- * Detail: an optional secondary error message carrying more detail about the problem.
+ -- Might run to multiple lines.
+ --
+ -- * Hint: an optional suggestion what to do about the problem.
+ -- This is intended to differ from detail in that it offers advice (potentially inappropriate)
+ -- rather than hard facts. Might run to multiple lines.
+ ServerError !ByteString !ByteString !(Maybe ByteString) !(Maybe ByteString) |
+ -- |
+ -- The database returned an unexpected result.
+ -- Indicates an improper statement or a schema mismatch.
+ UnexpectedResult !Text |
+ -- |
+ -- An error of the row reader, preceded by the index of the row.
+ RowError !Int !Row.Error |
+ -- |
+ -- An unexpected amount of rows.
+ UnexpectedAmountOfRows !Int
+ deriving (Show)
+
+{-# INLINE run #-}
+run :: Result a -> (Bool, LibPQ.Result) -> IO (Either Error a)
+run (Result reader) env =
+ runEitherT (runReaderT reader env)
+
+{-# INLINE unit #-}
+unit :: Result ()
+unit =
+ 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) -> EitherT $
+ 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
+ _ -> Result $ lift $ EitherT $ pure $ Left $ UnexpectedResult $ "Unexpected result status: " <> (fromString $ show status)
+
+{-# INLINE serverError #-}
+serverError :: Result ()
+serverError =
+ Result $ ReaderT $ \(_, result) -> EitherT $ do
+ code <-
+ fmap (fromMaybe ($bug "No code")) $
+ LibPQ.resultErrorField result LibPQ.DiagSqlstate
+ message <-
+ fmap (fromMaybe ($bug "No message")) $
+ LibPQ.resultErrorField result LibPQ.DiagMessagePrimary
+ detail <-
+ LibPQ.resultErrorField result LibPQ.DiagMessageDetail
+ hint <-
+ LibPQ.resultErrorField result LibPQ.DiagMessageHint
+ pure $ Left $ ServerError code message detail hint
+
+{-# INLINE maybe #-}
+maybe :: Row.Row a -> Result (Maybe a)
+maybe rowDec =
+ do
+ checkExecStatus $ \case
+ LibPQ.TuplesOk -> True
+ _ -> False
+ Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do
+ maxRows <- LibPQ.ntuples result
+ case maxRows of
+ 0 -> return (Right Nothing)
+ 1 -> do
+ maxCols <- LibPQ.nfields result
+ fmap (fmap Just . mapLeft (RowError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes)
+ _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))
+ where
+ rowToInt (LibPQ.Row n) =
+ fromIntegral n
+ intToRow =
+ LibPQ.Row . fromIntegral
+
+{-# INLINE single #-}
+single :: Row.Row a -> Result a
+single rowDec =
+ do
+ checkExecStatus $ \case
+ LibPQ.TuplesOk -> True
+ _ -> False
+ Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do
+ maxRows <- LibPQ.ntuples result
+ case maxRows of
+ 1 -> do
+ maxCols <- LibPQ.nfields result
+ fmap (mapLeft (RowError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes)
+ _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))
+ where
+ rowToInt (LibPQ.Row n) =
+ fromIntegral n
+ intToRow =
+ LibPQ.Row . fromIntegral
+
+{-# INLINE vector #-}
+vector :: Row.Row a -> Result (Vector a)
+vector rowDec =
+ do
+ checkExecStatus $ \case
+ LibPQ.TuplesOk -> True
+ _ -> False
+ Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ 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 !x -> writeIORef failureRef (Just (RowError rowIndex 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) -> EitherT $ {-# 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 !x -> writeIORef failureRef (Just (RowError rowIndex 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) -> EitherT $ 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 !x -> writeIORef failureRef (Just (RowError rowIndex 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
diff --git a/library/Hasql/Private/Decoders/Results.hs b/library/Hasql/Private/Decoders/Results.hs
new file mode 100644
index 0000000..03f4e36
--- /dev/null
+++ b/library/Hasql/Private/Decoders/Results.hs
@@ -0,0 +1,91 @@
+-- |
+-- An API for retrieval of multiple results.
+-- Can be used to handle:
+--
+-- * A single result,
+--
+-- * Individual results of a multi-statement query
+-- with the help of "Applicative" and "Monad",
+--
+-- * Row-by-row fetching.
+--
+module Hasql.Private.Decoders.Results where
+
+import Hasql.Private.Prelude hiding (maybe, many)
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified Hasql.Private.Prelude as Prelude
+import qualified Hasql.Private.Decoders.Result as Result
+import qualified Hasql.Private.Decoders.Row as Row
+
+
+newtype Results a =
+ Results (ReaderT (Bool, LibPQ.Connection) (EitherT Error IO) a)
+ deriving (Functor, Applicative, Monad)
+
+data Error =
+ -- |
+ -- An error on the client-side,
+ -- with a message generated by the \"libpq\" library.
+ -- Usually indicates problems with the connection.
+ ClientError !(Maybe ByteString) |
+ ResultError !Result.Error
+ deriving (Show)
+
+{-# INLINE run #-}
+run :: Results a -> (Bool, LibPQ.Connection) -> IO (Either Error a)
+run (Results stack) env =
+ runEitherT (runReaderT stack env)
+
+{-# INLINE clientError #-}
+clientError :: Results a
+clientError =
+ Results $ ReaderT $ \(_, connection) -> EitherT $
+ fmap (Left . ClientError) (LibPQ.errorMessage connection)
+
+-- |
+-- Parse a single result.
+{-# INLINE single #-}
+single :: Result.Result a -> Results a
+single resultDec =
+ Results $ ReaderT $ \(integerDatetimes, connection) -> EitherT $ 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) -> EitherT $ 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 =
+ EitherT $ fmap (mapLeft ResultError) $ Result.run Result.unit (integerDatetimes, result)
diff --git a/library/Hasql/Private/Decoders/Row.hs b/library/Hasql/Private/Decoders/Row.hs
new file mode 100644
index 0000000..e88997b
--- /dev/null
+++ b/library/Hasql/Private/Decoders/Row.hs
@@ -0,0 +1,65 @@
+module Hasql.Private.Decoders.Row where
+
+import Hasql.Private.Prelude
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified PostgreSQL.Binary.Decoding as A
+import qualified Hasql.Private.Decoders.Value as Value
+
+
+newtype Row a =
+ Row (ReaderT Env (EitherT Error IO) a)
+ deriving (Functor, Applicative, Monad)
+
+data Env =
+ Env !LibPQ.Result !LibPQ.Row !LibPQ.Column !Bool !(IORef LibPQ.Column)
+
+data Error =
+ EndOfInput |
+ UnexpectedNull |
+ ValueError !Text
+ deriving (Show)
+
+
+-- * Functions
+-------------------------
+
+{-# INLINE run #-}
+run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either Error a)
+run (Row impl) (result, row, columnsAmount, integerDatetimes) =
+ do
+ columnRef <- newIORef 0
+ runEitherT (runReaderT impl (Env result row columnsAmount integerDatetimes columnRef))
+
+{-# INLINE error #-}
+error :: Error -> Row a
+error x =
+ Row (ReaderT (const (EitherT (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) -> EitherT $ 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
diff --git a/library/Hasql/Private/Decoders/Value.hs b/library/Hasql/Private/Decoders/Value.hs
new file mode 100644
index 0000000..351d080
--- /dev/null
+++ b/library/Hasql/Private/Decoders/Value.hs
@@ -0,0 +1,27 @@
+module Hasql.Private.Decoders.Value where
+
+import Hasql.Private.Prelude
+import qualified PostgreSQL.Binary.Decoding as A
+
+
+newtype Value a =
+ Value (ReaderT Bool A.Value a)
+ deriving (Functor)
+
+
+{-# INLINE run #-}
+run :: Value a -> Bool -> A.Value a
+run (Value imp) integerDatetimes =
+ runReaderT imp integerDatetimes
+
+{-# INLINE decoder #-}
+decoder :: (Bool -> A.Value a) -> Value a
+decoder =
+ {-# SCC "decoder" #-}
+ Value . ReaderT
+
+{-# INLINE decoderFn #-}
+decoderFn :: (Bool -> ByteString -> Either Text a) -> Value a
+decoderFn fn =
+ Value $ ReaderT $ \integerDatetimes -> A.fn $ fn integerDatetimes
+
diff --git a/library/Hasql/Private/Encoders/Array.hs b/library/Hasql/Private/Encoders/Array.hs
new file mode 100644
index 0000000..ddc9efd
--- /dev/null
+++ b/library/Hasql/Private/Encoders/Array.hs
@@ -0,0 +1,30 @@
+module Hasql.Private.Encoders.Array where
+
+import Hasql.Private.Prelude
+import qualified PostgreSQL.Binary.Encoding as A
+import qualified Hasql.Private.PTI as B
+
+
+data Array a =
+ Array B.OID B.OID (Bool -> a -> A.Array)
+
+{-# INLINE run #-}
+run :: Array a -> (B.OID, Bool -> a -> A.Encoding)
+run (Array valueOID arrayOID encoder) =
+ (arrayOID, \env input -> A.array (B.oidWord32 valueOID) (encoder env input))
+
+{-# INLINE value #-}
+value :: B.OID -> B.OID -> (Bool -> a -> A.Encoding) -> Array a
+value valueOID arrayOID encoder =
+ Array valueOID arrayOID (\params -> A.encodingArray . encoder params)
+
+{-# INLINE nullableValue #-}
+nullableValue :: B.OID -> B.OID -> (Bool -> a -> A.Encoding) -> Array (Maybe a)
+nullableValue valueOID arrayOID encoder =
+ Array valueOID arrayOID (\params -> maybe A.nullArray (A.encodingArray . encoder params))
+
+{-# INLINE dimension #-}
+dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c
+dimension fold (Array valueOID arrayOID encoder) =
+ Array valueOID arrayOID (\params -> A.dimensionArray fold (encoder params))
+
diff --git a/library/Hasql/Private/Encoders/Params.hs b/library/Hasql/Private/Encoders/Params.hs
new file mode 100644
index 0000000..121c907
--- /dev/null
+++ b/library/Hasql/Private/Encoders/Params.hs
@@ -0,0 +1,51 @@
+module Hasql.Private.Encoders.Params where
+
+import Hasql.Private.Prelude
+import qualified Database.PostgreSQL.LibPQ as A
+import qualified PostgreSQL.Binary.Encoding as B
+import qualified Hasql.Private.Encoders.Value as C
+import qualified Hasql.Private.PTI as D
+
+
+-- |
+-- Encoder of some representation of a parameters product.
+newtype Params a =
+ Params (Op (DList (A.Oid, Bool -> Maybe ByteString)) a)
+ deriving (Contravariant, Divisible, Decidable, Monoid)
+
+instance Semigroup (Params a)
+
+run :: Params a -> a -> DList (A.Oid, Bool -> Maybe ByteString)
+run (Params (Op op)) params =
+ {-# SCC "run" #-}
+ op params
+
+run' :: Params a -> a -> Bool -> ([A.Oid], [Maybe (ByteString, A.Format)])
+run' (Params (Op op)) params integerDatetimes =
+ {-# SCC "run'" #-}
+ foldr step ([], []) (op params)
+ where
+ step (oid, bytesGetter) ~(oidList, bytesAndFormatList) =
+ (,)
+ (oid : oidList)
+ (fmap (\bytes -> (bytes, A.Binary)) (bytesGetter integerDatetimes) : bytesAndFormatList)
+
+run'' :: Params a -> a -> Bool -> [Maybe (A.Oid, ByteString, A.Format)]
+run'' (Params (Op op)) params integerDatetimes =
+ {-# SCC "run''" #-}
+ foldr step [] (op params)
+ where
+ step a b =
+ mapping a : b
+ where
+ mapping (oid, bytesGetter) =
+ (,,) <$> pure oid <*> bytesGetter integerDatetimes <*> pure A.Binary
+
+value :: C.Value a -> Params a
+value =
+ contramap Just . nullableValue
+
+nullableValue :: C.Value a -> Params (Maybe a)
+nullableValue (C.Value valueOID arrayOID encoder) =
+ Params $ Op $ \input ->
+ pure (D.oidPQ valueOID, \env -> fmap (B.encodingBytes . encoder env) input)
diff --git a/library/Hasql/Private/Encoders/Value.hs b/library/Hasql/Private/Encoders/Value.hs
new file mode 100644
index 0000000..e255a27
--- /dev/null
+++ b/library/Hasql/Private/Encoders/Value.hs
@@ -0,0 +1,26 @@
+module Hasql.Private.Encoders.Value where
+
+import Hasql.Private.Prelude
+import qualified PostgreSQL.Binary.Encoding as B
+import qualified Hasql.Private.PTI as PTI
+
+
+data Value a =
+ Value PTI.OID PTI.OID (Bool -> a -> B.Encoding)
+
+instance Contravariant Value where
+ {-# INLINE contramap #-}
+ contramap f (Value valueOID arrayOID encoder) =
+ Value valueOID arrayOID (\integerDatetimes input -> encoder integerDatetimes (f input))
+
+{-# INLINE run #-}
+run :: Value a -> (PTI.OID, PTI.OID, Bool -> a -> B.Encoding)
+run (Value valueOID arrayOID encoder') =
+ (valueOID, arrayOID, encoder')
+
+{-# INLINE unsafePTI #-}
+unsafePTI :: PTI.PTI -> (Bool -> a -> B.Encoding) -> Value a
+unsafePTI pti encoder' =
+ Value (PTI.ptiOID pti) (fromMaybe ($bug "No array OID") (PTI.ptiArrayOID pti)) encoder'
+
+
diff --git a/library/Hasql/Private/IO.hs b/library/Hasql/Private/IO.hs
new file mode 100644
index 0000000..a268a5b
--- /dev/null
+++ b/library/Hasql/Private/IO.hs
@@ -0,0 +1,159 @@
+-- |
+-- An API of low-level IO operations.
+module Hasql.Private.IO
+where
+
+import Hasql.Private.Prelude
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified Hasql.Private.Commands as Commands
+import qualified Hasql.Private.PreparedStatementRegistry as PreparedStatementRegistry
+import qualified Hasql.Private.Decoders.Result as ResultDecoders
+import qualified Hasql.Private.Decoders.Results as ResultsDecoders
+import qualified Hasql.Private.Encoders.Params as ParamsEncoders
+import qualified Data.DList as DList
+
+
+{-# 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 ResultsDecoders.Error 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 ResultsDecoders.Error 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.unit
+ 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 ResultsDecoders.Error ())
+checkedSend connection send =
+ send >>= \case
+ False -> fmap (Left . ResultsDecoders.ClientError) $ LibPQ.errorMessage connection
+ True -> pure (Right ())
+
+{-# INLINE sendPreparedParametricQuery #-}
+sendPreparedParametricQuery ::
+ LibPQ.Connection ->
+ PreparedStatementRegistry.PreparedStatementRegistry ->
+ ByteString ->
+ [LibPQ.Oid] ->
+ [Maybe (ByteString, LibPQ.Format)] ->
+ IO (Either ResultsDecoders.Error ())
+sendPreparedParametricQuery connection registry template oidList valueAndFormatList =
+ runEitherT $ do
+ key <- EitherT $ getPreparedStatementKey connection registry template oidList
+ EitherT $ checkedSend connection $ LibPQ.sendQueryPrepared connection key valueAndFormatList LibPQ.Binary
+
+{-# INLINE sendUnpreparedParametricQuery #-}
+sendUnpreparedParametricQuery ::
+ LibPQ.Connection ->
+ ByteString ->
+ [Maybe (LibPQ.Oid, ByteString, LibPQ.Format)] ->
+ IO (Either ResultsDecoders.Error ())
+sendUnpreparedParametricQuery connection template paramList =
+ checkedSend connection $ LibPQ.sendQueryParams connection template paramList LibPQ.Binary
+
+{-# INLINE sendParametricQuery #-}
+sendParametricQuery ::
+ LibPQ.Connection ->
+ Bool ->
+ PreparedStatementRegistry.PreparedStatementRegistry ->
+ ByteString ->
+ ParamsEncoders.Params a ->
+ Bool ->
+ a ->
+ IO (Either ResultsDecoders.Error ())
+sendParametricQuery connection integerDatetimes registry template encoder prepared params =
+ {-# SCC "sendParametricQuery" #-}
+ if prepared
+ then
+ let
+ (oidList, valueAndFormatList) =
+ ParamsEncoders.run' encoder params integerDatetimes
+ in
+ sendPreparedParametricQuery connection registry template oidList valueAndFormatList
+ else
+ let
+ paramList =
+ ParamsEncoders.run'' encoder params integerDatetimes
+ in
+ sendUnpreparedParametricQuery connection template paramList
+
+{-# INLINE sendNonparametricQuery #-}
+sendNonparametricQuery :: LibPQ.Connection -> ByteString -> IO (Either ResultsDecoders.Error ())
+sendNonparametricQuery connection sql =
+ checkedSend connection $ LibPQ.sendQuery connection sql
diff --git a/library/Hasql/Private/PTI.hs b/library/Hasql/Private/PTI.hs
new file mode 100644
index 0000000..5c34214
--- /dev/null
+++ b/library/Hasql/Private/PTI.hs
@@ -0,0 +1,94 @@
+module Hasql.Private.PTI where
+
+import Hasql.Private.Prelude hiding (bool)
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+
+
+-- | 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 }
+
+mkOID :: Word32 -> OID
+mkOID x =
+ OID x ((LibPQ.Oid . fromIntegral) x)
+
+mkPTI :: Word32 -> Maybe Word32 -> PTI
+mkPTI oid arrayOID =
+ PTI (mkOID oid) (fmap mkOID arrayOID)
+
+
+-- * Constants
+-------------------------
+
+abstime = mkPTI 702 (Just 1023)
+aclitem = mkPTI 1033 (Just 1034)
+bit = mkPTI 1560 (Just 1561)
+bool = mkPTI 16 (Just 1000)
+box = mkPTI 603 (Just 1020)
+bpchar = mkPTI 1042 (Just 1014)
+bytea = mkPTI 17 (Just 1001)
+char = mkPTI 18 (Just 1002)
+cid = mkPTI 29 (Just 1012)
+cidr = mkPTI 650 (Just 651)
+circle = mkPTI 718 (Just 719)
+cstring = mkPTI 2275 (Just 1263)
+date = mkPTI 1082 (Just 1182)
+daterange = mkPTI 3912 (Just 3913)
+float4 = mkPTI 700 (Just 1021)
+float8 = mkPTI 701 (Just 1022)
+gtsvector = mkPTI 3642 (Just 3644)
+inet = mkPTI 869 (Just 1041)
+int2 = mkPTI 21 (Just 1005)
+int2vector = mkPTI 22 (Just 1006)
+int4 = mkPTI 23 (Just 1007)
+int4range = mkPTI 3904 (Just 3905)
+int8 = mkPTI 20 (Just 1016)
+int8range = mkPTI 3926 (Just 3927)
+interval = mkPTI 1186 (Just 1187)
+json = mkPTI 114 (Just 199)
+jsonb = mkPTI 3802 (Just 3807)
+line = mkPTI 628 (Just 629)
+lseg = mkPTI 601 (Just 1018)
+macaddr = mkPTI 829 (Just 1040)
+money = mkPTI 790 (Just 791)
+name = mkPTI 19 (Just 1003)
+numeric = mkPTI 1700 (Just 1231)
+numrange = mkPTI 3906 (Just 3907)
+oid = mkPTI 26 (Just 1028)
+oidvector = mkPTI 30 (Just 1013)
+path = mkPTI 602 (Just 1019)
+point = mkPTI 600 (Just 1017)
+polygon = mkPTI 604 (Just 1027)
+record = mkPTI 2249 (Just 2287)
+refcursor = mkPTI 1790 (Just 2201)
+regclass = mkPTI 2205 (Just 2210)
+regconfig = mkPTI 3734 (Just 3735)
+regdictionary = mkPTI 3769 (Just 3770)
+regoper = mkPTI 2203 (Just 2208)
+regoperator = mkPTI 2204 (Just 2209)
+regproc = mkPTI 24 (Just 1008)
+regprocedure = mkPTI 2202 (Just 2207)
+regtype = mkPTI 2206 (Just 2211)
+reltime = mkPTI 703 (Just 1024)
+text = mkPTI 25 (Just 1009)
+tid = mkPTI 27 (Just 1010)
+time = mkPTI 1083 (Just 1183)
+timestamp = mkPTI 1114 (Just 1115)
+timestamptz = mkPTI 1184 (Just 1185)
+timetz = mkPTI 1266 (Just 1270)
+tinterval = mkPTI 704 (Just 1025)
+tsquery = mkPTI 3615 (Just 3645)
+tsrange = mkPTI 3908 (Just 3909)
+tstzrange = mkPTI 3910 (Just 3911)
+tsvector = mkPTI 3614 (Just 3643)
+txid_snapshot = mkPTI 2970 (Just 2949)
+unknown = mkPTI 705 (Just 705)
+uuid = mkPTI 2950 (Just 2951)
+varbit = mkPTI 1562 (Just 1563)
+varchar = mkPTI 1043 (Just 1015)
+void = mkPTI 2278 Nothing
+xid = mkPTI 28 (Just 1011)
+xml = mkPTI 142 (Just 143)
+
diff --git a/library/Hasql/Private/Prelude.hs b/library/Hasql/Private/Prelude.hs
new file mode 100644
index 0000000..164d1c8
--- /dev/null
+++ b/library/Hasql/Private/Prelude.hs
@@ -0,0 +1,130 @@
+module Hasql.Private.Prelude
+(
+ module Exports,
+ LazyByteString,
+ ByteStringBuilder,
+ LazyText,
+ TextBuilder,
+ bug,
+ bottom,
+ forMToZero_,
+ forMFromZero_,
+ strictCons,
+)
+where
+
+
+-- base-prelude
+-------------------------
+import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, fromLeft, fromRight, error, (<>), First(..), Last(..), new)
+
+-- transformers
+-------------------------
+import Control.Monad.IO.Class as Exports
+import Control.Monad.Trans.Class as Exports
+import Control.Monad.Trans.Maybe as Exports hiding (liftListen, liftPass)
+import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch)
+import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass)
+import Data.Functor.Identity as Exports
+
+-- mtl
+-------------------------
+import Control.Monad.Error.Class as Exports (MonadError (..))
+
+-- data-default-class
+-------------------------
+import Data.Default.Class as Exports
+
+-- profunctors
+-------------------------
+import Data.Profunctor.Unsafe as Exports
+
+-- contravariant
+-------------------------
+import Data.Functor.Contravariant as Exports
+import Data.Functor.Contravariant.Divisible as Exports
+
+-- contravariant-extras
+-------------------------
+import Contravariant.Extras as Exports
+
+-- either
+-------------------------
+import Control.Monad.Trans.Either as Exports
+import Data.Either.Combinators as Exports
+
+-- semigroups
+-------------------------
+import Data.Semigroup as Exports
+
+-- hashable
+-------------------------
+import Data.Hashable as Exports (Hashable(..))
+
+-- text
+-------------------------
+import Data.Text as Exports (Text)
+
+-- bytestring
+-------------------------
+import Data.ByteString as Exports (ByteString)
+
+-- vector
+-------------------------
+import Data.Vector as Exports (Vector)
+
+-- dlist
+-------------------------
+import Data.DList as Exports (DList)
+
+-- placeholders
+-------------------------
+import Development.Placeholders as Exports
+
+-- loch-th
+-------------------------
+import Debug.Trace.LocationTH as Exports
+
+-- custom
+-------------------------
+import qualified Debug.Trace.LocationTH
+import qualified Data.Text.Lazy
+import qualified Data.Text.Lazy.Builder
+import qualified Data.ByteString.Lazy
+import qualified Data.ByteString.Builder
+
+
+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
+
+bug =
+ [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |]
+ where
+ msg = "A \"hasql\" package bug: " :: String
+
+bottom =
+ [e| $bug "Bottom evaluated" |]
+
+{-# 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
diff --git a/library/Hasql/Private/PreparedStatementRegistry.hs b/library/Hasql/Private/PreparedStatementRegistry.hs
new file mode 100644
index 0000000..ce672ff
--- /dev/null
+++ b/library/Hasql/Private/PreparedStatementRegistry.hs
@@ -0,0 +1,56 @@
+module Hasql.Private.PreparedStatementRegistry
+(
+ PreparedStatementRegistry,
+ new,
+ update,
+ LocalKey(..),
+)
+where
+
+import Hasql.Private.Prelude hiding (lookup)
+import qualified Data.HashTable.IO as A
+import qualified ByteString.StrictBuilder as B
+
+
+data PreparedStatementRegistry =
+ PreparedStatementRegistry !(A.BasicHashTable LocalKey ByteString) !(IORef Word)
+
+{-# INLINABLE new #-}
+new :: IO PreparedStatementRegistry
+new =
+ PreparedStatementRegistry <$> A.new <*> newIORef 0
+
+{-# INLINABLE 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
diff --git a/library/Hasql/Private/Query.hs b/library/Hasql/Private/Query.hs
new file mode 100644
index 0000000..ff45cb0
--- /dev/null
+++ b/library/Hasql/Private/Query.hs
@@ -0,0 +1,61 @@
+module Hasql.Private.Query
+where
+
+import Hasql.Private.Prelude
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified Hasql.Private.IO as IO
+import qualified Hasql.Private.Connection as Connection
+import qualified Hasql.Private.Decoders.Results as Decoders.Results
+import qualified Hasql.Private.Encoders.Params as Encoders.Params
+
+
+-- |
+-- An abstraction over parametric queries.
+--
+-- It is composable using
+-- the standard interfaces of the category theory,
+-- which it has instances of.
+-- E.g., here's how you can compose queries
+-- using the Arrow notation:
+--
+-- @
+-- -- |
+-- -- Given an Update query,
+-- -- which uses the \@fmap (> 0) 'Decoders.Results.rowsAffected'\@ decoder
+-- -- to detect, whether it had any effect,
+-- -- and an Insert query,
+-- -- produces a query which performs Upsert.
+-- composeUpsert :: Query a Bool -> Query a () -> Query a ()
+-- composeUpsert update insert =
+-- proc params -> do
+-- updated <- update -< params
+-- if updated
+-- then 'returnA' -< ()
+-- else insert -< params
+-- @
+newtype Query a b =
+ Query (Kleisli (ReaderT Connection.Connection (EitherT Decoders.Results.Error IO)) a b)
+ deriving (Category, Arrow, ArrowChoice, ArrowLoop, ArrowApply)
+
+instance Functor (Query a) where
+ {-# INLINE fmap #-}
+ fmap =
+ (^<<)
+
+instance Profunctor Query where
+ {-# INLINE lmap #-}
+ lmap =
+ (^>>)
+ {-# INLINE rmap #-}
+ rmap =
+ (^<<)
+
+statement :: ByteString -> Encoders.Params.Params a -> Decoders.Results.Results b -> Bool -> Query a b
+statement template encoder decoder preparable =
+ Query $ Kleisli $ \params ->
+ ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) ->
+ EitherT $ withMVar pqConnectionRef $ \pqConnection -> do
+ r1 <- IO.sendParametricQuery pqConnection integerDatetimes registry template encoder preparable params
+ r2 <- IO.getResults pqConnection integerDatetimes decoder
+ return $ r1 *> r2
+
diff --git a/library/Hasql/Private/Session.hs b/library/Hasql/Private/Session.hs
new file mode 100644
index 0000000..d09845f
--- /dev/null
+++ b/library/Hasql/Private/Session.hs
@@ -0,0 +1,117 @@
+module Hasql.Private.Session
+where
+
+import Hasql.Private.Prelude
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified Hasql.Private.Decoders.Results as Decoders.Results
+import qualified Hasql.Private.Decoders.Result as Decoders.Result
+import qualified Hasql.Private.Settings as Settings
+import qualified Hasql.Private.IO as IO
+import qualified Hasql.Private.Query as Query
+import qualified Hasql.Private.Connection as Connection
+
+
+-- |
+-- A batch of actions to be executed in the context of a database connection.
+newtype Session a =
+ Session (ReaderT Connection.Connection (EitherT Error IO) a)
+ deriving (Functor, Applicative, Monad, MonadError Error, MonadIO)
+
+-- |
+-- Executes a bunch of commands on the provided connection.
+run :: Session a -> Connection.Connection -> IO (Either Error a)
+run (Session impl) connection =
+ runEitherT $
+ 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) ->
+ EitherT $ fmap (mapLeft unsafeCoerce) $ withMVar pqConnectionRef $ \pqConnection -> do
+ r1 <- IO.sendNonparametricQuery pqConnection sql
+ r2 <- IO.getResults pqConnection integerDatetimes decoder
+ return $ r1 *> r2
+ where
+ decoder =
+ Decoders.Results.single $
+ Decoders.Result.unit
+
+-- |
+-- Parameters and a specification of the parametric query to apply them to.
+query :: a -> Query.Query a b -> Session b
+query input (Query.Query (Kleisli impl)) =
+ Session $ unsafeCoerce $ impl input
+
+
+-- * Error
+-------------------------
+
+-- |
+-- An error of some command in the session.
+data Error =
+ -- |
+ -- An error on the client-side,
+ -- with a message generated by the \"libpq\" library.
+ -- Usually indicates problems with connection.
+ ClientError !(Maybe ByteString) |
+ -- |
+ -- Some error with a command result.
+ ResultError !ResultError
+ deriving (Show, Eq)
+
+-- |
+-- An error with a command result.
+data ResultError =
+ -- |
+ -- An error reported by the DB.
+ -- Consists of the following: Code, message, details, hint.
+ --
+ -- * __Code__.
+ -- The SQLSTATE code for the error.
+ -- It's recommended to use
+ -- <http://hackage.haskell.org/package/postgresql-error-codes the "postgresql-error-codes" package>
+ -- to work with those.
+ --
+ -- * __Message__.
+ -- The primary human-readable error message (typically one line). Always present.
+ --
+ -- * __Details__.
+ -- An optional secondary error message carrying more detail about the problem.
+ -- Might run to multiple lines.
+ --
+ -- * __Hint__.
+ -- An optional suggestion on what to do about the problem.
+ -- This is intended to differ from detail in that it offers advice (potentially inappropriate)
+ -- rather than hard facts.
+ -- Might run to multiple lines.
+ ServerError !ByteString !ByteString !(Maybe ByteString) !(Maybe ByteString) |
+ -- |
+ -- The database returned an unexpected result.
+ -- Indicates an improper statement or a schema mismatch.
+ UnexpectedResult !Text |
+ -- |
+ -- An error of the row reader, preceded by the index of the row.
+ RowError !Int !RowError |
+ -- |
+ -- An unexpected amount of rows.
+ UnexpectedAmountOfRows !Int
+ deriving (Show, Eq)
+
+-- |
+-- An error during the decoding of a specific row.
+data RowError =
+ -- |
+ -- Appears on the attempt to parse more columns than there are in the result.
+ EndOfInput |
+ -- |
+ -- Appears on the attempt to parse a @NULL@ as some value.
+ UnexpectedNull |
+ -- |
+ -- Appears when a wrong value parser is used.
+ -- Comes with the error details.
+ ValueError !Text
+ deriving (Show, Eq)
diff --git a/library/Hasql/Private/Settings.hs b/library/Hasql/Private/Settings.hs
new file mode 100644
index 0000000..80c1cf6
--- /dev/null
+++ b/library/Hasql/Private/Settings.hs
@@ -0,0 +1,39 @@
+module Hasql.Private.Settings where
+
+import Hasql.Private.Prelude
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy.Builder as BB
+import qualified Data.ByteString.Lazy.Builder.ASCII as BB
+import qualified Data.ByteString.Lazy as BL
+
+
+
+-- |
+-- 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)
+ ]
+
diff --git a/library/Hasql/Query.hs b/library/Hasql/Query.hs
new file mode 100644
index 0000000..491cd5e
--- /dev/null
+++ b/library/Hasql/Query.hs
@@ -0,0 +1,57 @@
+module Hasql.Query
+(
+ Query.Query,
+ statement,
+)
+where
+
+import Hasql.Private.Prelude
+import qualified Hasql.Private.Query as Query
+import qualified Hasql.Private.Decoders.Results as Decoders.Results
+import qualified Hasql.Decoders as Decoders
+import qualified Hasql.Private.Encoders.Params as Encoders.Params
+import qualified Hasql.Encoders as Encoders
+
+
+
+-- |
+-- A specification of a strictly single-statement query, which can be parameterized and prepared.
+--
+-- Consists of the following:
+--
+-- * SQL template,
+-- * params encoder,
+-- * result decoder,
+-- * a flag, determining whether it should be prepared.
+--
+-- The SQL template must be formatted according to Postgres' standard,
+-- with any non-ASCII characters of the template encoded using UTF-8.
+-- According to the format,
+-- parameters must be referred to using the positional notation, as in the following:
+-- @$1@, @$2@, @$3@ and etc.
+-- Those references must be used to refer to the values of the 'Encoders.Params' encoder.
+--
+-- Following is an example of the declaration of a prepared statement with its associated codecs.
+--
+-- @
+-- selectSum :: Hasql.Query.'Query.Query' (Int64, Int64) Int64
+-- selectSum =
+-- Hasql.Query.'statement' sql encoder decoder True
+-- where
+-- sql =
+-- "select ($1 + $2)"
+-- encoder =
+-- 'contramap' 'fst' (Hasql.Encoders.'Hasql.Encoders.value' Hasql.Encoders.'Hasql.Encoders.int8') '<>'
+-- 'contramap' 'snd' (Hasql.Encoders.'Hasql.Encoders.value' Hasql.Encoders.'Hasql.Encoders.int8')
+-- decoder =
+-- Hasql.Decoders.'Hasql.Decoders.singleRow' (Hasql.Decoders.'Hasql.Decoders.value' Hasql.Decoders.'Hasql.Decoders.int8')
+-- @
+--
+-- The statement above accepts a product of two parameters of type 'Int64'
+-- and produces a single result of type 'Int64'.
+--
+{-# INLINE statement #-}
+statement :: ByteString -> Encoders.Params a -> Decoders.Result b -> Bool -> Query.Query a b
+statement =
+ unsafeCoerce Query.statement
+
diff --git a/library/Hasql/Session.hs b/library/Hasql/Session.hs
index 94623f6..29aa2b9 100644
--- a/library/Hasql/Session.hs
+++ b/library/Hasql/Session.hs
@@ -1,9 +1,15 @@
module Hasql.Session
(
- Session,
- batch,
+ Session.Session,
+ Session.sql,
+ Session.query,
+ -- * Execution
+ Session.Error(..),
+ Session.ResultError(..),
+ Session.RowError(..),
+ Session.run,
)
where
-import Hasql.Core.Session
+import qualified Hasql.Private.Session as Session
diff --git a/library/Hasql/Statement.hs b/library/Hasql/Statement.hs
deleted file mode 100644
index eea6af0..0000000
--- a/library/Hasql/Statement.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module Hasql.Statement
-(
- Statement,
- prepared,
- unprepared,
-)
-where
-
-import Hasql.Core.Statement
diff --git a/profiling/Main.hs b/profiling/Main.hs
index 86b3298..b8b725c 100644
--- a/profiling/Main.hs
+++ b/profiling/Main.hs
@@ -1,63 +1,98 @@
module Main where
-import Prelude hiding (session)
+import Prelude
import Bug
import qualified Hasql.Connection as A
-import qualified Hasql.Batch as J
-import qualified Hasql.Session as F
-import qualified Hasql.DecodeResult as B
-import qualified Hasql.DecodeRow as C
-import qualified Hasql.DecodePrimitive as D
-import qualified Hasql.Statement as G
-import qualified Data.Vector as H
-import qualified Control.Foldl as I
+import qualified Hasql.Session as B
+import qualified Hasql.Query as C
+import qualified Hasql.Decoders as D
+import qualified Hasql.Encoders as E
+import qualified Data.Vector as F
main =
do
- connection <- connect
+ Right connection <- acquireConnection
traceEventIO "START Session"
- Right !result <- fmap force <$> A.session connection (session 10 10 100)
+ Right result <- B.run sessionWithManySmallResults connection
traceEventIO "STOP Session"
return ()
-
-connect :: IO A.Connection
-connect =
- do
- openingResult <- A.open (A.TCPConnectionSettings "localhost" 5432) "postgres" "" Nothing handleErrorOrNotification
- case openingResult of
- Left error -> fail (showString "Can't connect: " (show error))
- Right connection -> return connection
where
- handleErrorOrNotification x =
- putStrLn ("Async event: " <> show x)
+ acquireConnection =
+ A.acquire settings
+ where
+ settings =
+ A.settings host port user password database
+ where
+ host = "localhost"
+ port = 5432
+ user = "postgres"
+ password = ""
+ database = "postgres"
+
-- * Sessions
-------------------------
-session :: Int -> Int -> Int -> F.Session [[[(Int64, Int64)]]]
-session amountOfQueries amountOfStatements amountOfRows =
- replicateM amountOfQueries (F.batch (replicateM amountOfStatements (manyRowsBatch amountOfRows (B.revList))))
- where
- replicateM cnt0 f =
- loop cnt0
- where
- loop cnt
- | cnt <= 0 = pure []
- | otherwise = liftA2 (:) f (loop (cnt - 1))
+sessionWithManySmallParameters :: Vector (Int64, Int64) -> B.Session ()
+sessionWithManySmallParameters =
+ $(todo "sessionWithManySmallParameters")
+
+sessionWithSingleLargeResultInVector :: B.Session (Vector (Int64, Int64))
+sessionWithSingleLargeResultInVector =
+ B.query () queryWithManyRowsInVector
+
+sessionWithSingleLargeResultInList :: B.Session (List (Int64, Int64))
+sessionWithSingleLargeResultInList =
+ B.query () queryWithManyRowsInList
+
+sessionWithManySmallResults :: B.Session (Vector (Int64, Int64))
+sessionWithManySmallResults =
+ F.replicateM 1000 (B.query () queryWithSingleRow)
--- * Queries
+
+-- * Statements
-------------------------
-manyRowsBatch :: Int -> (C.DecodeRow (Int64, Int64) -> B.DecodeResult result) -> J.Batch result
-manyRowsBatch amountOfRows decodeResult =
- J.statement (G.unprepared template conquer decode) ()
+queryWithManyParameters :: C.Query (Vector (Int64, Int64)) ()
+queryWithManyParameters =
+ $(todo "statementWithManyParameters")
+
+queryWithSingleRow :: C.Query () (Int64, Int64)
+queryWithSingleRow =
+ C.statement template encoder decoder True
where
template =
- "SELECT generate_series(0," <> fromString (show amountOfRows) <> ") as a, generate_series(10000," <> fromString (show (amountOfRows + 10000)) <> ") as b"
- decode =
- decodeResult $
- tuple <$> C.primitive D.int8 <*> C.primitive D.int8
- where
+ "SELECT 1, 2"
+ encoder =
+ conquer
+ decoder =
+ D.singleRow row
+ where
+ row =
+ tuple <$> D.value D.int8 <*> D.value D.int8
+ where
+ tuple !a !b =
+ (a, b)
+
+queryWithManyRows :: (D.Row (Int64, Int64) -> D.Result result) -> C.Query () result
+queryWithManyRows decoder =
+ C.statement template encoder (decoder rowDecoder) True
+ where
+ template =
+ "SELECT generate_series(0,1000) as a, generate_series(1000,2000) as b"
+ encoder =
+ conquer
+ rowDecoder =
+ tuple <$> D.value D.int8 <*> D.value D.int8
+ where
tuple !a !b =
(a, b)
+
+queryWithManyRowsInVector :: C.Query () (Vector (Int64, Int64))
+queryWithManyRowsInVector =
+ queryWithManyRows D.rowsVector
+
+queryWithManyRowsInList :: C.Query () (List (Int64, Int64))
+queryWithManyRowsInList =
+ queryWithManyRows D.rowsList
diff --git a/tasty/Main.hs b/tasty/Main.hs
new file mode 100644
index 0000000..0b4aab5
--- /dev/null
+++ b/tasty/Main.hs
@@ -0,0 +1,417 @@
+module Main where
+
+import Main.Prelude hiding (assert)
+import Test.QuickCheck.Instances
+import Test.Tasty
+import Test.Tasty.Runners
+import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck
+import qualified Test.QuickCheck as QuickCheck
+import qualified Main.Queries as Queries
+import qualified Main.DSL as DSL
+import qualified Main.Connection as Connection
+import qualified Hasql.Query as Query
+import qualified Hasql.Encoders as Encoders
+import qualified Hasql.Decoders as Decoders
+import qualified Hasql.Session as Session
+
+main =
+ defaultMain tree
+
+tree =
+ localOption (NumThreads 1) $
+ testGroup "All tests"
+ [
+ testCase "IN simulation" $
+ let
+ query =
+ Query.statement "select true where 1 = any ($1)" encoder decoder True
+ where
+ encoder =
+ Encoders.value (Encoders.array (Encoders.arrayDimension foldl' (Encoders.arrayValue Encoders.int8)))
+ decoder =
+ fmap (maybe False (const True)) (Decoders.maybeRow (Decoders.value Decoders.bool))
+ session =
+ do
+ result1 <- Session.query [1, 2] query
+ result2 <- Session.query [2, 3] query
+ return (result1, result2)
+ in do
+ x <- Connection.with (Session.run session)
+ assertEqual (show x) (Right (Right (True, False))) x
+ ,
+ testCase "NOT IN simulation" $
+ let
+ query =
+ Query.statement "select true where 3 <> all ($1)" encoder decoder True
+ where
+ encoder =
+ Encoders.value (Encoders.array (Encoders.arrayDimension foldl' (Encoders.arrayValue Encoders.int8)))
+ decoder =
+ fmap (maybe False (const True)) (Decoders.maybeRow (Decoders.value Decoders.bool))
+ session =
+ do
+ result1 <- Session.query [1, 2] query
+ result2 <- Session.query [2, 3] query
+ return (result1, result2)
+ in do
+ x <- Connection.with (Session.run session)
+ assertEqual (show x) (Right (Right (True, False))) x
+ ,
+ testCase "Composite decoding" $
+ let
+ query =
+ Query.statement sql encoder decoder True
+ where
+ sql =
+ "select (1, true)"
+ encoder =
+ Encoders.unit
+ decoder =
+ Decoders.singleRow (Decoders.value (Decoders.composite ((,) <$> Decoders.compositeValue Decoders.int8 <*> Decoders.compositeValue Decoders.bool)))
+ session =
+ Session.query () query
+ in do
+ x <- Connection.with (Session.run session)
+ assertEqual (show x) (Right (Right (1, True))) x
+ ,
+ testCase "Complex composite decoding" $
+ let
+ query =
+ Query.statement sql encoder decoder True
+ where
+ sql =
+ "select (1, true) as entity1, ('hello', 3) as entity2"
+ encoder =
+ Encoders.unit
+ decoder =
+ Decoders.singleRow $
+ (,) <$> Decoders.value entity1 <*> Decoders.value entity2
+ where
+ entity1 =
+ Decoders.composite $
+ (,) <$> Decoders.compositeValue Decoders.int8 <*> Decoders.compositeValue Decoders.bool
+ entity2 =
+ Decoders.composite $
+ (,) <$> Decoders.compositeValue Decoders.text <*> Decoders.compositeValue Decoders.int8
+ session =
+ Session.query () query
+ in do
+ x <- Connection.with (Session.run session)
+ assertEqual (show x) (Right (Right ((1, True), ("hello", 3)))) x
+ ,
+ testCase "Empty array" $
+ let
+ io =
+ do
+ x <- Connection.with (Session.run session)
+ assertEqual (show x) (Right (Right [])) x
+ where
+ session =
+ Session.query () query
+ where
+ query =
+ Query.statement sql encoder decoder True
+ where
+ sql =
+ "select array[]::int8[]"
+ encoder =
+ Encoders.unit
+ decoder =
+ Decoders.singleRow (Decoders.value (Decoders.array (Decoders.arrayDimension replicateM (Decoders.arrayValue Decoders.int8))))
+ in io
+ ,
+ testCase "Failing prepared statements" $
+ let
+ io =
+ Connection.with (Session.run session) >>=
+ (assertBool <$> show <*> resultTest)
+ where
+ resultTest =
+ \case
+ Right (Left (Session.ResultError (Session.ServerError "26000" _ _ _))) -> False
+ _ -> True
+ session =
+ catchError session (const (pure ())) *> session
+ where
+ session =
+ Session.query () query
+ where
+ query =
+ Query.statement sql encoder decoder True
+ where
+ sql =
+ "absurd"
+ encoder =
+ Encoders.unit
+ decoder =
+ Decoders.unit
+ in io
+ ,
+ testCase "Prepared statements after error" $
+ let
+ io =
+ Connection.with (Session.run session) >>=
+ \x -> assertBool (show x) (either (const False) isRight x)
+ where
+ session =
+ try *> fail *> try
+ where
+ try =
+ Session.query 1 query
+ where
+ query =
+ Query.statement sql encoder decoder True
+ where
+ sql =
+ "select $1 :: int8"
+ encoder =
+ Encoders.value Encoders.int8
+ decoder =
+ Decoders.singleRow $ Decoders.value Decoders.int8
+ fail =
+ catchError (Session.sql "absurd") (const (pure ()))
+ in io
+ ,
+ testCase "\"in progress after error\" bugfix" $
+ let
+ sumQuery :: Query.Query (Int64, Int64) Int64
+ sumQuery =
+ Query.statement sql encoder decoder True
+ where
+ sql =
+ "select ($1 + $2)"
+ encoder =
+ contramap fst (Encoders.value Encoders.int8) <>
+ contramap snd (Encoders.value Encoders.int8)
+ decoder =
+ Decoders.singleRow (Decoders.value Decoders.int8)
+ sumSession :: Session.Session Int64
+ sumSession =
+ Session.sql "begin" *> Session.query (1, 1) sumQuery <* Session.sql "end"
+ errorSession :: Session.Session ()
+ errorSession =
+ Session.sql "asldfjsldk"
+ io =
+ Connection.with $ \c -> do
+ Session.run errorSession c
+ Session.run sumSession c
+ in io >>= \x -> assertBool (show x) (either (const False) isRight x)
+ ,
+ testCase "\"another command is already in progress\" bugfix" $
+ let
+ sumQuery :: Query.Query (Int64, Int64) Int64
+ sumQuery =
+ Query.statement sql encoder decoder True
+ where
+ sql =
+ "select ($1 + $2)"
+ encoder =
+ contramap fst (Encoders.value Encoders.int8) <>
+ contramap snd (Encoders.value Encoders.int8)
+ decoder =
+ Decoders.singleRow (Decoders.value Decoders.int8)
+ session :: Session.Session Int64
+ session =
+ do
+ Session.sql "begin;"
+ s <- Session.query (1,1) sumQuery
+ Session.sql "end;"
+ return s
+ in DSL.session session >>= \x -> assertEqual (show x) (Right 2) x
+ ,
+ testCase "Executing the same query twice" $
+ pure ()
+ ,
+ testCase "Interval Encoding" $
+ let
+ actualIO =
+ DSL.session $ do
+ let
+ query =
+ Query.statement sql encoder decoder True
+ where
+ sql =
+ "select $1 = interval '10 seconds'"
+ decoder =
+ (Decoders.singleRow (Decoders.value (Decoders.bool)))
+ encoder =
+ Encoders.value (Encoders.interval)
+ in DSL.query (10 :: DiffTime) query
+ in actualIO >>= \x -> assertEqual (show x) (Right True) x
+ ,
+ testCase "Interval Decoding" $
+ let
+ actualIO =
+ DSL.session $ do
+ let
+ query =
+ Query.statement sql encoder decoder True
+ where
+ sql =
+ "select interval '10 seconds'"
+ decoder =
+ (Decoders.singleRow (Decoders.value (Decoders.interval)))
+ encoder =
+ Encoders.unit
+ in DSL.query () query
+ in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x
+ ,
+ testCase "Interval Encoding/Decoding" $
+ let
+ actualIO =
+ DSL.session $ do
+ let
+ query =
+ Query.statement sql encoder decoder True
+ where
+ sql =
+ "select $1"
+ decoder =
+ (Decoders.singleRow (Decoders.value (Decoders.interval)))
+ encoder =
+ Encoders.value (Encoders.interval)
+ in DSL.query (10 :: DiffTime) query
+ in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x
+ ,
+ testCase "Unknown" $
+ let
+ actualIO =
+ DSL.session $ do
+ let
+ query =
+ Query.statement sql mempty Decoders.unit True
+ where
+ sql =
+ "drop type if exists mood"
+ in DSL.query () query
+ let
+ query =
+ Query.statement sql mempty Decoders.unit True
+ where
+ sql =
+ "create type mood as enum ('sad', 'ok', 'happy')"
+ in DSL.query () query
+ let
+ query =
+ Query.statement sql encoder decoder True
+ where
+ sql =
+ "select $1 = ('ok' :: mood)"
+ decoder =
+ (Decoders.singleRow (Decoders.value (Decoders.bool)))
+ encoder =
+ Encoders.value (Encoders.unknown)
+ in DSL.query "ok" query
+ in actualIO >>= assertEqual "" (Right True)
+ ,
+ testCase "Enum" $
+ let
+ actualIO =
+ DSL.session $ do
+ let
+ query =
+ Query.statement sql mempty Decoders.unit True
+ where
+ sql =
+ "drop type if exists mood"
+ in DSL.query () query
+ let
+ query =
+ Query.statement sql mempty Decoders.unit True
+ where
+ sql =
+ "create type mood as enum ('sad', 'ok', 'happy')"
+ in DSL.query () query
+ let
+ query =
+ Query.statement sql encoder decoder True
+ where
+ sql =
+ "select ($1 :: mood)"
+ decoder =
+ (Decoders.singleRow (Decoders.value (Decoders.enum (Just . id))))
+ encoder =
+ Encoders.value (Encoders.enum id)
+ in DSL.query "ok" query
+ in actualIO >>= assertEqual "" (Right "ok")
+ ,
+ testCase "The same prepared statement used on different types" $
+ let
+ actualIO =
+ DSL.session $ do
+ let
+ effect1 =
+ DSL.query "ok" query
+ where
+ query =
+ Query.statement sql encoder decoder True
+ where
+ sql =
+ "select $1"
+ encoder =
+ Encoders.value Encoders.text
+ decoder =
+ (Decoders.singleRow (Decoders.value (Decoders.text)))
+ effect2 =
+ DSL.query 1 query
+ where
+ query =
+ Query.statement sql encoder decoder True
+ where
+ sql =
+ "select $1"
+ encoder =
+ Encoders.value Encoders.int8
+ decoder =
+ (Decoders.singleRow (Decoders.value Decoders.int8))
+ in (,) <$> effect1 <*> effect2
+ in actualIO >>= assertEqual "" (Right ("ok", 1))
+ ,
+ testCase "Affected rows counting" $
+ replicateM_ 13 $
+ let
+ actualIO =
+ DSL.session $ do
+ dropTable
+ createTable
+ replicateM_ 100 insertRow
+ deleteRows <* dropTable
+ where
+ dropTable =
+ DSL.query () $ Queries.plain $
+ "drop table if exists a"
+ createTable =
+ DSL.query () $ Queries.plain $
+ "create table a (id bigserial not null, name varchar not null, primary key (id))"
+ insertRow =
+ DSL.query () $ Queries.plain $
+ "insert into a (name) values ('a')"
+ deleteRows =
+ DSL.query () $ Query.statement sql def decoder False
+ where
+ sql =
+ "delete from a"
+ decoder =
+ Decoders.rowsAffected
+ in actualIO >>= assertEqual "" (Right 100)
+ ,
+ testCase "Result of an auto-incremented column" $
+ let
+ actualIO =
+ DSL.session $ do
+ DSL.query () $ Queries.plain $ "drop table if exists a"
+ DSL.query () $ Queries.plain $ "create table a (id serial not null, v char not null, primary key (id))"
+ id1 <- DSL.query () $ Query.statement "insert into a (v) values ('a') returning id" def (Decoders.singleRow (Decoders.value Decoders.int4)) False
+ id2 <- DSL.query () $ Query.statement "insert into a (v) values ('b') returning id" def (Decoders.singleRow (Decoders.value Decoders.int4)) False
+ DSL.query () $ Queries.plain $ "drop table if exists a"
+ pure (id1, id2)
+ in assertEqual "" (Right (1, 2)) =<< actualIO
+ ,
+ testCase "List decoding" $
+ let
+ actualIO =
+ DSL.session $ DSL.query () $ Queries.selectList
+ in assertEqual "" (Right [(1, 2), (3, 4), (5, 6)]) =<< actualIO
+ ]
+
diff --git a/tasty/Main/Connection.hs b/tasty/Main/Connection.hs
new file mode 100644
index 0000000..f0ee39a
--- /dev/null
+++ b/tasty/Main/Connection.hs
@@ -0,0 +1,28 @@
+module Main.Connection
+where
+
+import Main.Prelude
+import qualified Hasql.Connection as HC
+import qualified Hasql.Query as HQ
+import qualified Hasql.Session
+
+
+with :: (HC.Connection -> IO a) -> IO (Either HC.ConnectionError a)
+with handler =
+ runEitherT $ acquire >>= \connection -> use connection <* release connection
+ where
+ acquire =
+ EitherT $ HC.acquire settings
+ where
+ settings =
+ HC.settings host port user password database
+ where
+ host = "localhost"
+ port = 5432
+ user = "postgres"
+ password = ""
+ database = "postgres"
+ use connection =
+ lift $ handler connection
+ release connection =
+ lift $ HC.release connection
diff --git a/tasty/Main/DSL.hs b/tasty/Main/DSL.hs
new file mode 100644
index 0000000..32c19b0
--- /dev/null
+++ b/tasty/Main/DSL.hs
@@ -0,0 +1,47 @@
+module Main.DSL
+(
+ Session,
+ SessionError(..),
+ session,
+ Hasql.Session.query,
+ Hasql.Session.sql,
+)
+where
+
+import Main.Prelude
+import qualified Hasql.Connection as HC
+import qualified Hasql.Query as HQ
+import qualified Hasql.Encoders as HE
+import qualified Hasql.Decoders as HD
+import qualified Hasql.Session
+
+
+type Session =
+ Hasql.Session.Session
+
+data SessionError =
+ ConnectionError (HC.ConnectionError) |
+ SessionError (Hasql.Session.Error)
+ deriving (Show, Eq)
+
+session :: Session a -> IO (Either SessionError a)
+session session =
+ runEitherT $ acquire >>= \connection -> use connection <* release connection
+ where
+ acquire =
+ EitherT $ fmap (mapLeft ConnectionError) $ HC.acquire settings
+ where
+ settings =
+ HC.settings host port user password database
+ where
+ host = "localhost"
+ port = 5432
+ user = "postgres"
+ password = ""
+ database = "postgres"
+ use connection =
+ EitherT $
+ fmap (mapLeft SessionError) $
+ Hasql.Session.run session connection
+ release connection =
+ lift $ HC.release connection
diff --git a/tasty/Main/Prelude.hs b/tasty/Main/Prelude.hs
new file mode 100644
index 0000000..c7f8dfb
--- /dev/null
+++ b/tasty/Main/Prelude.hs
@@ -0,0 +1,14 @@
+module Main.Prelude
+(
+ module Exports,
+)
+where
+
+
+-- rerebase
+-------------------------
+import Prelude as Exports
+
+-- data-default-class
+-------------------------
+import Data.Default.Class as Exports
diff --git a/tasty/Main/Queries.hs b/tasty/Main/Queries.hs
new file mode 100644
index 0000000..afaa40d
--- /dev/null
+++ b/tasty/Main/Queries.hs
@@ -0,0 +1,36 @@
+module Main.Queries where
+
+import Main.Prelude hiding (def)
+import qualified Hasql.Query as HQ
+import qualified Hasql.Encoders as HE
+import qualified Hasql.Decoders as HD
+import qualified Main.Prelude as Prelude
+
+
+def :: ByteString -> HQ.Query () ()
+def sql =
+ HQ.statement sql Prelude.def Prelude.def False
+
+plain :: ByteString -> HQ.Query () ()
+plain sql =
+ HQ.statement sql mempty HD.unit False
+
+dropType :: ByteString -> HQ.Query () ()
+dropType name =
+ plain $
+ "drop type if exists " <> name
+
+createEnum :: ByteString -> [ByteString] -> HQ.Query () ()
+createEnum name values =
+ plain $
+ "create type " <> name <> " as enum (" <>
+ mconcat (intersperse ", " (map (\x -> "'" <> x <> "'") values)) <> ")"
+
+selectList :: HQ.Query () ([] (Int64, Int64))
+selectList =
+ HQ.statement sql mempty decoder True
+ where
+ sql =
+ "values (1,2), (3,4), (5,6)"
+ decoder =
+ HD.rowsList ((,) <$> HD.value HD.int8 <*> HD.value HD.int8)
diff --git a/tests/Main.hs b/tests/Main.hs
deleted file mode 100644
index 4d24d42..0000000
--- a/tests/Main.hs
+++ /dev/null
@@ -1,80 +0,0 @@
-module Main where
-
-import Prelude
-import Bug
-import Test.QuickCheck.Instances
-import Test.Tasty
-import Test.Tasty.Runners
-import Test.Tasty.HUnit
-import Test.Tasty.QuickCheck
-import qualified Hasql.Connection as A
-import qualified Hasql.Batch as J
-import qualified Hasql.DecodeResult as B
-import qualified Hasql.DecodeRow as C
-import qualified Hasql.DecodePrimitive as D
-import qualified Hasql.Statement as E
-import qualified Data.Vector as H
-import qualified Control.Foldl as I
-
-
-main =
- connect >>= runTests
-
-connect :: IO A.Connection
-connect =
- do
- openingResult <- A.open (A.TCPConnectionSettings "localhost" 5432) "postgres" "" Nothing handleErrorOrNotification
- case openingResult of
- Left error -> fail (showString "Can't connect: " (show error))
- Right connection -> return connection
- where
- handleErrorOrNotification x =
- putStrLn ("Async event: " <> show x)
-
-runTests :: A.Connection -> IO ()
-runTests connection =
- defaultMain $
- testGroup "Tests with connection" $
- [
- let
- test :: (Eq result, Show result) => String -> Either A.Error result -> J.Batch result -> TestTree
- test name expectedResult query =
- testCase name $ do
- result <- A.batch connection query
- assertEqual "" expectedResult result
- in
- testGroup "Batch" $
- [
- test "select 1" (Right 1) $
- J.statement (E.prepared "select 1" conquer (B.head (C.primitive D.int8))) ()
- ,
- test "select '1' and select 'true'" (Right (1, True)) $
- (,) <$>
- J.statement (E.prepared "select 1" conquer (B.head (C.primitive D.int8))) () <*>
- J.statement (E.prepared "select 'true' :: bool" conquer (B.head (C.primitive D.bool))) ()
- ,
- test "Error" (Left (A.BackendError "42703" "column \"abc\" does not exist")) $
- J.statement (E.prepared "select abc" conquer (B.head (C.primitive D.int8))) ()
- ,
- test "Errors in multiple queries" (Left (A.BackendError "42703" "column \"abc\" does not exist")) $
- J.statement (E.unprepared "select 1" conquer (B.head (C.primitive D.int8))) () *>
- J.statement (E.unprepared "select abc" conquer (B.head (C.primitive D.int8))) () *>
- J.statement (E.unprepared "select abc" conquer (B.head (C.primitive D.int8))) ()
- ,
- test "traverse" (Right [1,2,3]) $
- traverse (\template -> J.statement (E.prepared template conquer (B.head (C.primitive D.int8))) ()) $
- ["select 1", "select 2", "select 3"]
- ,
- test "Not a single row" (Left (A.DecodingError "Empty query")) $
- J.statement (E.prepared "" conquer (B.head (C.primitive D.int8))) ()
- ,
- testCaseInfo "Simultaneous result decoding and counting" $ pure "Pending"
- ]
- ,
- testCase "Failed prepared statement should be forgotten" $ do
- result1 <- A.batch connection $
- J.statement (E.prepared "fail 'Failed prepared statement 1'" conquer B.ignore) ()
- result2 <- A.batch connection $
- J.statement (E.prepared "fail 'Failed prepared statement 1'" conquer B.ignore) ()
- assertEqual "" (Left (A.BackendError "42601" "syntax error at or near \"fail\"")) result2
- ]
diff --git a/threads-test/Main.hs b/threads-test/Main.hs
new file mode 100644
index 0000000..93ca7f5
--- /dev/null
+++ b/threads-test/Main.hs
@@ -0,0 +1,45 @@
+module Main where
+
+import Rebase.Prelude
+import qualified Hasql.Connection
+import qualified Hasql.Query
+import qualified Hasql.Encoders
+import qualified Hasql.Decoders
+import qualified Hasql.Session
+import qualified Main.Queries as Queries
+
+
+main =
+ acquire >>= use
+ where
+ acquire =
+ (,) <$> acquire <*> acquire
+ where
+ acquire =
+ join $
+ fmap (either (fail . show) return) $
+ Hasql.Connection.acquire connectionSettings
+ where
+ connectionSettings =
+ Hasql.Connection.settings "localhost" 5432 "postgres" "" "postgres"
+ use (connection1, connection2) =
+ do
+ beginVar <- newEmptyMVar
+ finishVar <- newEmptyMVar
+ forkIO $ do
+ traceM "1: in"
+ putMVar beginVar ()
+ session connection1 (Hasql.Session.query 0.2 Queries.selectSleep)
+ traceM "1: out"
+ void (tryPutMVar finishVar False)
+ forkIO $ do
+ takeMVar beginVar
+ traceM "2: in"
+ session connection2 (Hasql.Session.query 0.1 Queries.selectSleep)
+ traceM "2: out"
+ void (tryPutMVar finishVar True)
+ bool exitFailure exitSuccess . traceShowId =<< takeMVar finishVar
+ where
+ session connection session =
+ Hasql.Session.run session connection >>=
+ either (fail . show) return
diff --git a/threads-test/Main/Queries.hs b/threads-test/Main/Queries.hs
new file mode 100644
index 0000000..1ca2bba
--- /dev/null
+++ b/threads-test/Main/Queries.hs
@@ -0,0 +1,20 @@
+module Main.Queries where
+
+import Rebase.Prelude
+import Hasql.Query
+import qualified Hasql.Encoders as E
+import qualified Hasql.Decoders as D
+
+
+selectSleep :: Query Double ()
+selectSleep =
+ statement sql encoder decoder True
+ where
+ sql =
+ "select pg_sleep($1)"
+ encoder =
+ E.value E.float8
+ decoder =
+ D.unit
+
+