git.iko.soy/rel8
on master help sign in
Export `select`, `insert`, `update` and `delete` as `Hasql.Statement`s (#94)
29cdfdbShane
Changelog.md+2
compare with master
unifiedsplit
@@ -45,6 +45,8 @@
45 * `Table` has a new associated type - `FromExprs`. This was previously an open type family.
45 * `Table` has a new associated type - `FromExprs`. This was previously an open type family.
46 * `Table` has a new associated type - `Transpose` - and `Recontextualise` has been renamed to `Transposes`. This `Transposes` class now operates in terms of `Transpose`.
46 * `Table` has a new associated type - `Transpose` - and `Recontextualise` has been renamed to `Transposes`. This `Transposes` class now operates in terms of `Transpose`.
47
47
48+* `select`, `insert`, `update` and `delete` now produce Hasql `Statement`s, rather than actually running the statement as IO. This allows Rel8 to be used with transaction/connection-managing monads like [`hasql-transaction`](https://hackage.haskell.org/package/hasql-transaction). ([#94](https://github.com/circuithub/rel8/pull/94))
49+
48## Bug fixes
50## Bug fixes
49
51
50* Fixes a bug where cartesian products of queries using `catListTable`, `catNonEmptyTable`, `catList` and `catNonEmpty` would incorrectly be zipped instead. ([#61](https://github.com/circuithub/rel8/pull/61))
52* Fixes a bug where cartesian products of queries using `catListTable`, `catNonEmptyTable`, `catList` and `catNonEmpty` would incorrectly be zipped instead. ([#61](https://github.com/circuithub/rel8/pull/61))
rel8.cabal+3−3
@@ -37,7 +37,6 @@ library
37 , text
37 , text
38 , these
38 , these
39 , time
39 , time
40− , transformers
41 , uuid
40 , uuid
42 default-language:
41 default-language:
43 Haskell2010
42 Haskell2010
@@ -201,9 +200,9 @@ test-suite tests
201 , case-insensitive
200 , case-insensitive
202 , containers
201 , containers
203 , hasql
202 , hasql
203+ , hasql-transaction
204 , hedgehog ^>=1.0.2
204 , hedgehog ^>=1.0.2
205− , lifted-base ^>=0.2.3.12
205+ , mmorph
206− , monad-control ^>=1.0.2.3
207 , rel8
206 , rel8
208 , scientific
207 , scientific
209 , tasty
208 , tasty
@@ -211,6 +210,7 @@ test-suite tests
211 , text
210 , text
212 , time
211 , time
213 , tmp-postgres ^>=1.34.1.0
212 , tmp-postgres ^>=1.34.1.0
213+ , transformers
214 , uuid
214 , uuid
215
215
216 other-modules:
216 other-modules:
src/Rel8/Query/SQL.hs+1−1
@@ -18,4 +18,4 @@ import Rel8.Table ( Table )
18
18
19-- | Convert a 'Query' to a 'String' containing a @SELECT@ statement.
19-- | Convert a 'Query' to a 'String' containing a @SELECT@ statement.
20showQuery :: Table Expr a => Query a -> String
20showQuery :: Table Expr a => Query a -> String
21−showQuery = foldMap show . ppSelect
21+showQuery = show . ppSelect
src/Rel8/Statement/Delete.hs+20−27
@@ -14,14 +14,11 @@ module Rel8.Statement.Delete
14where
14where
15
15
16-- base
16-- base
17−import Control.Exception ( throwIO )
18import Data.Kind ( Type )
17import Data.Kind ( Type )
19import Prelude
18import Prelude
20
19
21-- hasql
20-- hasql
22−import Hasql.Connection ( Connection )
23import qualified Hasql.Encoders as Hasql
21import qualified Hasql.Encoders as Hasql
24−import qualified Hasql.Session as Hasql
25import qualified Hasql.Statement as Hasql
22import qualified Hasql.Statement as Hasql
26
23
27-- pretty
24-- pretty
@@ -32,10 +29,7 @@ import Rel8.Expr ( Expr )
32import Rel8.Query ( Query )
29import Rel8.Query ( Query )
33import Rel8.Schema.Name ( Selects )
30import Rel8.Schema.Name ( Selects )
34import Rel8.Schema.Table ( TableSchema, ppTable )
31import Rel8.Schema.Table ( TableSchema, ppTable )
35−import Rel8.Statement.Returning
32+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )
36− ( Returning
37− , decodeReturning, emptyReturning, ppReturning
38− )
39import Rel8.Statement.Using ( ppUsing )
33import Rel8.Statement.Using ( ppUsing )
40import Rel8.Statement.Where ( ppWhere )
34import Rel8.Statement.Where ( ppWhere )
41
35
@@ -61,26 +55,25 @@ data Delete a where
61 -> Delete a
55 -> Delete a
62
56
63
57
64−ppDelete :: Delete a -> Maybe Doc
58+ppDelete :: Delete a -> Doc
65−ppDelete Delete {..} = do
59+ppDelete Delete {..} = case ppUsing using of
66− (usingDoc, i) <- ppUsing using
60+ Nothing ->
67− pure $ text "DELETE FROM" <+> ppTable from
61+ text "DELETE FROM" <+> ppTable from $$
62+ text "WHERE false"
68− $$ usingDoc
63+ Just (usingDoc, i) ->
64+ text "DELETE FROM" <+> ppTable from $$
65+ usingDoc $$
69− $$ ppWhere from (deleteWhere i)
66+ ppWhere from (deleteWhere i) $$
70− $$ ppReturning from returning
67+ ppReturning from returning
71
68
72
69
73-- | Run a 'Delete' statement.
70-- | Run a 'Delete' statement.
74−delete :: Connection -> Delete a -> IO a
71+delete :: Delete a -> Hasql.Statement () a
75−delete connection d@Delete {returning} =
72+delete d@Delete {returning} = Hasql.Statement bytes params decode prepare
76− case show <$> ppDelete d of
77− Nothing -> pure (emptyReturning returning)
78− Just sql ->
79− Hasql.run session connection >>= either throwIO pure
80− where
73+ where
81− session = Hasql.statement () statement
82− statement = Hasql.Statement bytes params decode prepare
83− bytes = encodeUtf8 $ Text.pack sql
74+ bytes = encodeUtf8 $ Text.pack sql
84− params = Hasql.noParams
75+ params = Hasql.noParams
85− decode = decodeReturning returning
76+ decode = decodeReturning returning
86− prepare = False
77+ prepare = False
78+ sql = show doc
79+ doc = ppDelete d
src/Rel8/Statement/Insert.hs+17−27
@@ -15,15 +15,12 @@ module Rel8.Statement.Insert
15where
15where
16
16
17-- base
17-- base
18−import Control.Exception ( throwIO )
19import Data.Foldable ( toList )
18import Data.Foldable ( toList )
20import Data.Kind ( Type )
19import Data.Kind ( Type )
21import Prelude
20import Prelude
22
21
23-- hasql
22-- hasql
24−import Hasql.Connection ( Connection )
25import qualified Hasql.Encoders as Hasql
23import qualified Hasql.Encoders as Hasql
26−import qualified Hasql.Session as Hasql
27import qualified Hasql.Statement as Hasql
24import qualified Hasql.Statement as Hasql
28
25
29-- opaleye
26-- opaleye
@@ -37,10 +34,7 @@ import Rel8.Query ( Query )
37import Rel8.Schema.Name ( Name, Selects, ppColumn )
34import Rel8.Schema.Name ( Name, Selects, ppColumn )
38import Rel8.Schema.Table ( TableSchema(..), ppTable )
35import Rel8.Schema.Table ( TableSchema(..), ppTable )
39import Rel8.Statement.OnConflict ( OnConflict, ppOnConflict )
36import Rel8.Statement.OnConflict ( OnConflict, ppOnConflict )
40−import Rel8.Statement.Returning
37+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )
41− ( Returning
42− , decodeReturning, emptyReturning, ppReturning
43− )
44import Rel8.Statement.Select ( ppSelect )
38import Rel8.Statement.Select ( ppSelect )
45import Rel8.Table ( Table )
39import Rel8.Table ( Table )
46import Rel8.Table.Name ( showNames )
40import Rel8.Table.Name ( showNames )
@@ -68,13 +62,13 @@ data Insert a where
68 -> Insert a
62 -> Insert a
69
63
70
64
71−ppInsert :: Insert a -> Maybe Doc
65+ppInsert :: Insert a -> Doc
72−ppInsert Insert {..} = do
66+ppInsert Insert {..} =
73− rows' <- ppSelect rows
74− pure $ text "INSERT INTO" <+> ppInto into
67+ text "INSERT INTO" <+>
68+ ppInto into $$
75− $$ rows'
69+ ppSelect rows $$
76− $$ ppOnConflict into onConflict
70+ ppOnConflict into onConflict $$
77− $$ ppReturning into returning
71+ ppReturning into returning
78
72
79
73
80ppInto :: Table Name a => TableSchema a -> Doc
74ppInto :: Table Name a => TableSchema a -> Doc
@@ -84,16 +78,12 @@ ppInto table@TableSchema {columns} =
84
78
85
79
86-- | Run an 'Insert' statement.
80-- | Run an 'Insert' statement.
87−insert :: Connection -> Insert a -> IO a
81+insert :: Insert a -> Hasql.Statement () a
88−insert connection i@Insert {returning} =
82+insert i@Insert {returning} = Hasql.Statement bytes params decode prepare
89− case show <$> ppInsert i of
90− Nothing -> pure (emptyReturning returning)
91− Just sql ->
92− Hasql.run session connection >>= either throwIO pure
93− where
83+ where
94− session = Hasql.statement () statement
95− statement = Hasql.Statement bytes params decode prepare
96− bytes = encodeUtf8 $ Text.pack sql
84+ bytes = encodeUtf8 $ Text.pack sql
97− params = Hasql.noParams
85+ params = Hasql.noParams
98− decode = decodeReturning returning
86+ decode = decodeReturning returning
99− prepare = False
87+ prepare = False
88+ sql = show doc
89+ doc = ppInsert i
src/Rel8/Statement/Returning.hs−7
@@ -9,9 +9,7 @@
9
9
10module Rel8.Statement.Returning
10module Rel8.Statement.Returning
11 ( Returning( NumberOfRowsAffected, Projection )
11 ( Returning( NumberOfRowsAffected, Projection )
12−
13 , decodeReturning
12 , decodeReturning
14− , emptyReturning
15 , ppReturning
13 , ppReturning
16 )
14 )
17where
15where
@@ -126,11 +124,6 @@ decodeReturning = runReturning
126 (\decoder withRows -> withRows <$> Hasql.rowList decoder)
124 (\decoder withRows -> withRows <$> Hasql.rowList decoder)
127
125
128
126
129−emptyReturning :: Returning names a -> a
130−emptyReturning =
131− runReturning (\withCount -> withCount 0) (\_ withRows -> withRows [])
132−
133−
134ppReturning :: TableSchema names -> Returning names a -> Doc
127ppReturning :: TableSchema names -> Returning names a -> Doc
135ppReturning schema returning = case projections schema returning of
128ppReturning schema returning = case projections schema returning of
136 Nothing -> mempty
129 Nothing -> mempty
src/Rel8/Statement/SQL.hs+3−3
@@ -16,14 +16,14 @@ import Rel8.Statement.Update ( Update, ppUpdate )
16
16
17-- | Convert a 'Delete' to a 'String' containing a @DELETE@ statement.
17-- | Convert a 'Delete' to a 'String' containing a @DELETE@ statement.
18showDelete :: Delete a -> String
18showDelete :: Delete a -> String
19−showDelete = foldMap show . ppDelete
19+showDelete = show . ppDelete
20
20
21
21
22-- | Convert an 'Insert' to a 'String' containing an @INSERT@ statement.
22-- | Convert an 'Insert' to a 'String' containing an @INSERT@ statement.
23showInsert :: Insert a -> String
23showInsert :: Insert a -> String
24−showInsert = foldMap show . ppInsert
24+showInsert = show . ppInsert
25
25
26
26
27-- | Convert an 'Update' to a 'String' containing an @UPDATE@ statement.
27-- | Convert an 'Update' to a 'String' containing an @UPDATE@ statement.
28showUpdate :: Update a -> String
28showUpdate :: Update a -> String
29−showUpdate = foldMap show . ppUpdate
29+showUpdate = show . ppUpdate
src/Rel8/Statement/Select.hs+23−25
@@ -15,15 +15,12 @@ module Rel8.Statement.Select
15where
15where
16
16
17-- base
17-- base
18−import Control.Exception ( throwIO )
19import Data.Void ( Void )
18import Data.Void ( Void )
20−import Prelude
19+import Prelude hiding ( undefined )
21
20
22-- hasql
21-- hasql
23−import Hasql.Connection ( Connection )
24import qualified Hasql.Decoders as Hasql
22import qualified Hasql.Decoders as Hasql
25import qualified Hasql.Encoders as Hasql
23import qualified Hasql.Encoders as Hasql
26−import qualified Hasql.Session as Hasql
27import qualified Hasql.Statement as Hasql
24import qualified Hasql.Statement as Hasql
28
25
29-- opaleye
26-- opaleye
@@ -39,6 +36,8 @@ import Text.PrettyPrint ( Doc )
39
36
40-- rel8
37-- rel8
41import Rel8.Expr ( Expr )
38import Rel8.Expr ( Expr )
39+import Rel8.Expr.Bool ( false )
40+import Rel8.Expr.Opaleye ( toPrimExpr )
42import Rel8.Query ( Query )
41import Rel8.Query ( Query )
43import Rel8.Query.Opaleye ( toOpaleye )
42import Rel8.Query.Opaleye ( toOpaleye )
44import Rel8.Schema.Name ( Selects )
43import Rel8.Schema.Name ( Selects )
@@ -47,6 +46,7 @@ import Rel8.Table.Cols ( toCols )
47import Rel8.Table.Name ( namesFromLabels )
46import Rel8.Table.Name ( namesFromLabels )
48import Rel8.Table.Opaleye ( castTable, exprsWithNames )
47import Rel8.Table.Opaleye ( castTable, exprsWithNames )
49import Rel8.Table.Serialize ( Serializable, parse )
48import Rel8.Table.Serialize ( Serializable, parse )
49+import Rel8.Table.Undefined ( undefined )
50
50
51-- text
51-- text
52import qualified Data.Text as Text
52import qualified Data.Text as Text
@@ -55,31 +55,29 @@ import Data.Text.Encoding ( encodeUtf8 )
55
55
56-- | Run a @SELECT@ statement, returning all rows.
56-- | Run a @SELECT@ statement, returning all rows.
57select :: forall exprs a. Serializable exprs a
57select :: forall exprs a. Serializable exprs a
58− => Connection -> Query exprs -> IO [a]
58+ => Query exprs -> Hasql.Statement () [a]
59−select c query = case ppSelect query of
59+select query = Hasql.Statement bytes params decode prepare
60− Nothing -> pure []
61− Just doc -> Hasql.run session c >>= either throwIO pure
62− where
60+ where
63− session = Hasql.statement () statement
64− statement = Hasql.Statement bytes params decode prepare
65− bytes = encodeUtf8 (Text.pack sql)
61+ bytes = encodeUtf8 (Text.pack sql)
66− params = Hasql.noParams
62+ params = Hasql.noParams
67− decode = Hasql.rowList (parse @exprs @a)
63+ decode = Hasql.rowList (parse @exprs @a)
68− prepare = False
64+ prepare = False
69− sql = show doc
65+ sql = show doc
70−
66+ doc = ppSelect query
71−
67+
68+
72−ppSelect :: Table Expr a => Query a -> Maybe Doc
69+ppSelect :: Table Expr a => Query a -> Doc
73−ppSelect query = do
70+ppSelect query =
74− primQuery' <- case optimize primQuery of
75− Empty -> Nothing
76− Unit -> Just Opaleye.Unit
77− Optimized primQuery' -> Just primQuery'
78− pure $ Opaleye.ppSql $ primSelectWith names (toCols exprs) primQuery'
71+ Opaleye.ppSql $ primSelectWith names (toCols exprs') primQuery'
79 where
72 where
80 names = namesFromLabels
73 names = namesFromLabels
81 (exprs, primQuery, _) =
74 (exprs, primQuery, _) =
82 Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
75 Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
76+ (exprs', primQuery') = case optimize primQuery of
77+ Empty -> (undefined, Opaleye.Product (pure (pure Opaleye.Unit)) never)
78+ Unit -> (exprs, Opaleye.Unit)
79+ Optimized pq -> (exprs, pq)
80+ never = pure (toPrimExpr false)
83
81
84
82
85ppPrimSelect :: Query a -> (Optimized Doc, a)
83ppPrimSelect :: Query a -> (Optimized Doc, a)
src/Rel8/Statement/Update.hs+18−26
@@ -13,14 +13,11 @@ module Rel8.Statement.Update
13where
13where
14
14
15-- base
15-- base
16−import Control.Exception ( throwIO )
17import Data.Kind ( Type )
16import Data.Kind ( Type )
18import Prelude
17import Prelude
19
18
20-- hasql
19-- hasql
21−import Hasql.Connection ( Connection )
22import qualified Hasql.Encoders as Hasql
20import qualified Hasql.Encoders as Hasql
23−import qualified Hasql.Session as Hasql
24import qualified Hasql.Statement as Hasql
21import qualified Hasql.Statement as Hasql
25
22
26-- pretty
23-- pretty
@@ -31,10 +28,7 @@ import Rel8.Expr ( Expr )
31import Rel8.Query ( Query )
28import Rel8.Query ( Query )
32import Rel8.Schema.Name ( Selects )
29import Rel8.Schema.Name ( Selects )
33import Rel8.Schema.Table ( TableSchema(..), ppTable )
30import Rel8.Schema.Table ( TableSchema(..), ppTable )
34−import Rel8.Statement.Returning
31+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )
35− ( Returning
36− , decodeReturning, emptyReturning, ppReturning
37− )
38import Rel8.Statement.Set ( ppSet )
32import Rel8.Statement.Set ( ppSet )
39import Rel8.Statement.Using ( ppFrom )
33import Rel8.Statement.Using ( ppFrom )
40import Rel8.Statement.Where ( ppWhere )
34import Rel8.Statement.Where ( ppWhere )
@@ -63,12 +57,14 @@ data Update a where
63 -> Update a
57 -> Update a
64
58
65
59
66−ppUpdate :: Update a -> Maybe Doc
60+ppUpdate :: Update a -> Doc
67−ppUpdate Update {..} = do
61+ppUpdate Update {..} = case ppFrom from of
62+ Nothing ->
63+ text "UPDATE" <+> ppTable target $$
64+ ppSet target id $$
65+ text "WHERE false"
68− (fromDoc, i) <- ppFrom from
66+ Just (fromDoc, i) ->
69− pure $
70− text "UPDATE" <+>
71− ppTable target $$
67+ text "UPDATE" <+> ppTable target $$
72 ppSet target (set i) $$
68 ppSet target (set i) $$
73 fromDoc $$
69 fromDoc $$
74 ppWhere target (updateWhere i) $$
70 ppWhere target (updateWhere i) $$
@@ -76,16 +72,12 @@ ppUpdate Update {..} = do
76
72
77
73
78-- | Run an @UPDATE@ statement.
74-- | Run an @UPDATE@ statement.
79−update :: Connection -> Update a -> IO a
75+update :: Update a -> Hasql.Statement () a
80−update connection u@Update {returning} =
76+update u@Update {returning} = Hasql.Statement bytes params decode prepare
81− case show <$> ppUpdate u of
82− Nothing -> pure (emptyReturning returning)
83− Just sql ->
84− Hasql.run session connection >>= either throwIO pure
85− where
77+ where
86− session = Hasql.statement () statement
87− statement = Hasql.Statement bytes params decode prepare
88− bytes = encodeUtf8 $ Text.pack sql
78+ bytes = encodeUtf8 $ Text.pack sql
89− params = Hasql.noParams
79+ params = Hasql.noParams
90− decode = decodeReturning returning
80+ decode = decodeReturning returning
91− prepare = False
81+ prepare = False
82+ sql = show doc
83+ doc = ppUpdate u
src/Rel8/Statement/View.hs+3−7
@@ -8,8 +8,6 @@ where
8
8
9-- base
9-- base
10import Control.Exception ( throwIO )
10import Control.Exception ( throwIO )
11−import Data.Foldable ( fold )
12−import Data.Maybe ( fromMaybe )
13import Prelude
11import Prelude
14
12
15-- hasql
13-- hasql
@@ -25,7 +23,6 @@ import Rel8.Schema.Name ( Selects )
25import Rel8.Schema.Table ( TableSchema )
23import Rel8.Schema.Table ( TableSchema )
26import Rel8.Statement.Insert ( ppInto )
24import Rel8.Statement.Insert ( ppInto )
27import Rel8.Statement.Select ( ppSelect )
25import Rel8.Statement.Select ( ppSelect )
28−import Rel8.Table.Alternative ( emptyTable )
29
26
30-- pretty
27-- pretty
31import Text.PrettyPrint ( Doc, (<+>), ($$), text )
28import Text.PrettyPrint ( Doc, (<+>), ($$), text )
@@ -49,7 +46,8 @@ createView connection schema query =
49 params = Hasql.noParams
46 params = Hasql.noParams
50 decode = Hasql.noResult
47 decode = Hasql.noResult
51 prepare = False
48 prepare = False
49+ sql = show doc
52− sql = show (ppCreateView schema query)
50+ doc = ppCreateView schema query
53
51
54
52
55ppCreateView :: Selects names exprs
53ppCreateView :: Selects names exprs
@@ -58,6 +56,4 @@ ppCreateView schema query =
58 text "CREATE VIEW" <+>
56 text "CREATE VIEW" <+>
59 ppInto schema $$
57 ppInto schema $$
60 text "AS" <+>
58 text "AS" <+>
61− fromMaybe fallback (ppSelect query)
62− where
63− fallback = fold (ppSelect (emptyTable `asTypeOf` query))
59+ ppSelect query
tests/Main.hs+180−165
@@ -1,30 +1,25 @@
1{-# language BlockArguments #-}
1{-# language BlockArguments #-}
2−{-# language DataKinds #-}
3{-# language DeriveAnyClass #-}
2{-# language DeriveAnyClass #-}
4{-# language DeriveGeneric #-}
3{-# language DeriveGeneric #-}
5{-# language DerivingStrategies #-}
4{-# language DerivingStrategies #-}
6−{-# language DisambiguateRecordFields #-}
7{-# language FlexibleContexts #-}
5{-# language FlexibleContexts #-}
8{-# language FlexibleInstances #-}
6{-# language FlexibleInstances #-}
9−{-# language GADTs #-}
7+{-# language MonoLocalBinds #-}
10−{-# language NamedFieldPuns #-}
11{-# language OverloadedStrings #-}
8{-# language OverloadedStrings #-}
12{-# language RecordWildCards #-}
9{-# language RecordWildCards #-}
13{-# language ScopedTypeVariables #-}
10{-# language ScopedTypeVariables #-}
14{-# language StandaloneDeriving #-}
11{-# language StandaloneDeriving #-}
15{-# language TypeApplications #-}
12{-# language TypeApplications #-}
16
13
17−{-# options_ghc -fno-warn-redundant-constraints #-}
18−
19module Main
14module Main
20 ( main
15 ( main
21 )
16 )
22where
17where
23
18
24-- base
19-- base
25−import Control.Applicative ( liftA2, liftA3 )
20+import Control.Applicative ( empty, liftA2, liftA3 )
26−import Control.Monad (void)
21+import Control.Exception ( bracket, throwIO )
27−import Control.Monad.IO.Class ( MonadIO, liftIO )
22+import Control.Monad ( (>=>), void )
28import Data.Bifunctor ( bimap )
23import Data.Bifunctor ( bimap )
29import Data.Foldable ( for_ )
24import Data.Foldable ( for_ )
30import Data.Int ( Int32, Int64 )
25import Data.Int ( Int32, Int64 )
@@ -38,25 +33,26 @@ import GHC.Generics ( Generic )
38import qualified Data.ByteString.Lazy
33import qualified Data.ByteString.Lazy
39
34
40-- case-insensitive
35-- case-insensitive
41−import Data.CaseInsensitive (mk)
36+import Data.CaseInsensitive ( mk )
42
37
43-- containers
38-- containers
44import qualified Data.Map.Strict as Map
39import qualified Data.Map.Strict as Map
45
40
46-- hasql
41-- hasql
47−import Hasql.Connection ( Connection, acquire, release )
42+import Hasql.Connection ( Connection, acquire, release )
48import Hasql.Session ( sql, run )
43import Hasql.Session ( sql, run )
49
44
45+-- hasql-transaction
46+import Hasql.Transaction ( Transaction, condemn, statement )
47+import qualified Hasql.Transaction.Sessions as Hasql
48+
50-- hedgehog
49-- hedgehog
51import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )
50import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )
52import qualified Hedgehog.Gen as Gen
51import qualified Hedgehog.Gen as Gen
53import qualified Hedgehog.Range as Range
52import qualified Hedgehog.Range as Range
54
53
55−-- lifted-base
54+-- mmorph
56−import Control.Exception.Lifted ( bracket, throwIO, bracket_ )
57−
58−-- monad-control
59−import Control.Monad.Trans.Control ( MonadBaseControl )
55+import Control.Monad.Morph ( hoist )
60
56
61-- rel8
57-- rel8
62import Rel8 ( Result )
58import Rel8 ( Result )
@@ -72,12 +68,16 @@ import Test.Tasty
72import Test.Tasty.Hedgehog ( testProperty )
68import Test.Tasty.Hedgehog ( testProperty )
73
69
74-- text
70-- text
75−import Data.Text (Text, pack)
71+import Data.Text ( Text, pack, unpack )
76import qualified Data.Text.Lazy
72import qualified Data.Text.Lazy
73+import Data.Text.Encoding ( decodeUtf8 )
77
74
78-- time
75-- time
79import Data.Time
76import Data.Time
80
77
78+-- transformers
79+import Control.Monad.Trans.Class ( lift )
80+
81-- tmp-postgres
81-- tmp-postgres
82import qualified Database.Postgres.Temp as TmpPostgres
82import qualified Database.Postgres.Temp as TmpPostgres
83
83
@@ -140,19 +140,21 @@ tests =
140 stopTestDatabase = TmpPostgres.stop
140 stopTestDatabase = TmpPostgres.stop
141
141
142
142
143+connect :: TmpPostgres.DB -> IO Connection
144+connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure
145+
146+
143databasePropertyTest
147databasePropertyTest
144 :: TestName
148 :: TestName
145− -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())
149+ -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ())
146 -> IO TmpPostgres.DB -> TestTree
150 -> IO TmpPostgres.DB -> TestTree
147databasePropertyTest testName f getTestDatabase =
151databasePropertyTest testName f getTestDatabase =
148− withResource connect release $ \c ->
152+ withResource (connect =<< getTestDatabase) release $ \c ->
149 testProperty testName $ property do
153 testProperty testName $ property do
150− connection <- liftIO c
154+ connection <- lift c
151− f \g -> test $ rollingBack connection $ g connection
155+ f $ test . hoist \m -> do
152−
156+ e <- run (Hasql.transaction Hasql.Serializable Hasql.Write (m <* condemn)) connection
153− where
157+ either throwIO pure e
154−
155− connect = either (error . show) return =<< acquire . TmpPostgres.toConnectionString =<< getTestDatabase
156
158
157
159
158data TestTable f = TestTable
160data TestTable f = TestTable
@@ -184,17 +186,17 @@ testSelectTestTable :: IO TmpPostgres.DB -> TestTree
184testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do
186testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do
185 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
187 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
186
188
187− transaction \connection -> do
189+ transaction do
188− liftIO $ Rel8.insert connection
190+ selected <- lift do
189− Rel8.Insert
191+ statement () $ Rel8.insert Rel8.Insert
190 { into = testTableSchema
192 { into = testTableSchema
191 , rows = Rel8.values $ map Rel8.lit rows
193 , rows = Rel8.values $ map Rel8.lit rows
192 , onConflict = Rel8.DoNothing
194 , onConflict = Rel8.DoNothing
193 , returning = pure ()
195 , returning = pure ()
194 }
196 }
195
197
196− selected <- liftIO $ Rel8.select connection do
198+ statement () $ Rel8.select do
197− Rel8.each testTableSchema
199+ Rel8.each testTableSchema
198
200
199 sort selected === sort rows
201 sort selected === sort rows
200
202
@@ -211,11 +213,12 @@ testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do
211
213
212 let expected = filter (\t -> testTableColumn2 t == magicBool) rows
214 let expected = filter (\t -> testTableColumn2 t == magicBool) rows
213
215
214− transaction \connection -> do
216+ transaction do
217+ selected <- lift do
215− selected <- liftIO $ Rel8.select connection do
218+ statement () $ Rel8.select do
216− t <- Rel8.values $ Rel8.lit <$> rows
219+ t <- Rel8.values $ Rel8.lit <$> rows
217− Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool
220+ Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool
218− return t
221+ return t
219
222
220 sort selected === sort expected
223 sort selected === sort expected
221
224
@@ -228,11 +231,12 @@ testFilter :: IO TmpPostgres.DB -> TestTree
228testFilter = databasePropertyTest "filter" \transaction -> do
231testFilter = databasePropertyTest "filter" \transaction -> do
229 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
232 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
230
233
231− transaction \connection -> do
234+ transaction do
232 let expected = filter testTableColumn2 rows
235 let expected = filter testTableColumn2 rows
233
236
234− selected <- liftIO $ Rel8.select connection
237+ selected <- lift do
238+ statement () $ Rel8.select do
235− $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
239+ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
236
240
237 sort selected === sort expected
241 sort selected === sort expected
238
242
@@ -247,9 +251,10 @@ testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do
247
251
248 n <- forAll $ Gen.integral (Range.linear 0 10)
252 n <- forAll $ Gen.integral (Range.linear 0 10)
249
253
250− transaction \connection -> do
254+ transaction do
255+ selected <- lift do
251− selected <- liftIO $ Rel8.select connection do
256+ statement () $ Rel8.select do
252− Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
257+ Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
253
258
254 diff (length selected) (<=) (fromIntegral n)
259 diff (length selected) (<=) (fromIntegral n)
255
260
@@ -267,9 +272,10 @@ testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do
267 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable
272 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable
268 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable
273 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable
269
274
270− transaction \connection -> do
275+ transaction do
276+ selected <- lift do
271− selected <- liftIO $ Rel8.select connection do
277+ statement () $ Rel8.select do
272− Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)
278+ Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)
273
279
274 sort selected === sort (nub (left ++ right))
280 sort selected === sort (nub (left ++ right))
275
281
@@ -278,9 +284,11 @@ testDistinct :: IO TmpPostgres.DB -> TestTree
278testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do
284testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do
279 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
285 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
280
286
281− transaction \connection -> do
287+ transaction do
288+ selected <- lift do
289+ statement () $ Rel8.select do
282− selected <- liftIO $ Rel8.select connection $ Rel8.distinct do
290+ Rel8.distinct do
283− Rel8.values (Rel8.lit <$> rows)
291+ Rel8.values (Rel8.lit <$> rows)
284
292
285 sort selected === nub (sort rows)
293 sort selected === nub (sort rows)
286
294
@@ -293,8 +301,10 @@ testExists :: IO TmpPostgres.DB -> TestTree
293testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do
301testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do
294 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
302 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
295
303
296− transaction \connection -> do
304+ transaction do
305+ exists <- lift do
306+ statement () $ Rel8.select do
297− exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
307+ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
298
308
299 case rows of
309 case rows of
300 [] -> exists === [False]
310 [] -> exists === [False]
@@ -305,9 +315,10 @@ testOptional :: IO TmpPostgres.DB -> TestTree
305testOptional = databasePropertyTest "Rel8.optional" \transaction -> do
315testOptional = databasePropertyTest "Rel8.optional" \transaction -> do
306 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
316 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
307
317
308− transaction \connection -> do
318+ transaction do
319+ selected <- lift do
309− selected <- liftIO $ Rel8.select connection do
320+ statement () $ Rel8.select do
310− Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
321+ Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
311
322
312 case rows of
323 case rows of
313 [] -> selected === [Nothing]
324 [] -> selected === [Nothing]
@@ -318,9 +329,10 @@ testAnd :: IO TmpPostgres.DB -> TestTree
318testAnd = databasePropertyTest "AND (&&.)" \transaction -> do
329testAnd = databasePropertyTest "AND (&&.)" \transaction -> do
319 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
330 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
320
331
321− transaction \connection -> do
332+ transaction do
322− [result] <- liftIO $ Rel8.select connection $ pure $
333+ [result] <- lift do
334+ statement () $ Rel8.select do
323− Rel8.lit x Rel8.&&. Rel8.lit y
335+ pure $ Rel8.lit x Rel8.&&. Rel8.lit y
324
336
325 result === (x && y)
337 result === (x && y)
326
338
@@ -329,9 +341,10 @@ testOr :: IO TmpPostgres.DB -> TestTree
329testOr = databasePropertyTest "OR (||.)" \transaction -> do
341testOr = databasePropertyTest "OR (||.)" \transaction -> do
330 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
342 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
331
343
332− transaction \connection -> do
344+ transaction do
345+ [result] <- lift do
333− [result] <- liftIO $ Rel8.select connection $ pure $
346+ statement () $ Rel8.select $ pure $
334− Rel8.lit x Rel8.||. Rel8.lit y
347+ Rel8.lit x Rel8.||. Rel8.lit y
335
348
336 result === (x || y)
349 result === (x || y)
337
350
@@ -340,9 +353,10 @@ testLogicalFixities :: IO TmpPostgres.DB -> TestTree
340testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do
353testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do
341 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool
354 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool
342
355
343− transaction \connection -> do
356+ transaction do
344− [result] <- liftIO $ Rel8.select connection $ pure $
357+ [result] <- lift do
358+ statement () $ Rel8.select do
345− Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x
359+ pure $ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x
346
360
347 result === (u || v && w == x)
361 result === (u || v && w == x)
348
362
@@ -351,9 +365,10 @@ testNot :: IO TmpPostgres.DB -> TestTree
351testNot = databasePropertyTest "NOT (not_)" \transaction -> do
365testNot = databasePropertyTest "NOT (not_)" \transaction -> do
352 x <- forAll Gen.bool
366 x <- forAll Gen.bool
353
367
354− transaction \connection -> do
368+ transaction do
355− [result] <- liftIO $ Rel8.select connection $ pure $
369+ [result] <- lift do
370+ statement () $ Rel8.select do
356− Rel8.not_ $ Rel8.lit x
371+ pure $ Rel8.not_ $ Rel8.lit x
357
372
358 result === not x
373 result === not x
359
374
@@ -362,9 +377,10 @@ testBool :: IO TmpPostgres.DB -> TestTree
362testBool = databasePropertyTest "ifThenElse_" \transaction -> do
377testBool = databasePropertyTest "ifThenElse_" \transaction -> do
363 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool
378 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool
364
379
365− transaction \connection -> do
380+ transaction do
366− [result] <- liftIO $ Rel8.select connection $ pure $
381+ [result] <- lift do
382+ statement () $ Rel8.select do
367− Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)
383+ pure $ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)
368
384
369 result === if x then y else z
385 result === if x then y else z
370
386
@@ -376,9 +392,10 @@ testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do
376 (Gen.list (Range.linear 1 10) genTestTable)
392 (Gen.list (Range.linear 1 10) genTestTable)
377 (Gen.list (Range.linear 1 10) genTestTable)
393 (Gen.list (Range.linear 1 10) genTestTable)
378
394
379− transaction \connection -> do
395+ transaction do
396+ result <- lift do
380− result <- liftIO $ Rel8.select connection $ do
397+ statement () $ Rel8.select do
381− liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
398+ liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
382
399
383 sort result === sort (liftA2 (,) rows1 rows2)
400 sort result === sort (liftA2 (,) rows1 rows2)
384
401
@@ -407,21 +424,22 @@ testDBType getTestDatabase = testGroup "DBType instances"
407 where
424 where
408 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree
425 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree
409 dbTypeTest name generator = testGroup name
426 dbTypeTest name generator = testGroup name
410− [ databasePropertyTest name (t (==) generator) getTestDatabase
427+ [ databasePropertyTest name (t generator) getTestDatabase
411− , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase
428+ , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase
412 ]
429 ]
413
430
414− t :: forall a b. (Show a, Rel8.Sql Rel8.DBType a)
431+ t :: forall a b. (Eq a, Show a, Rel8.Sql Rel8.DBType a)
415− => (a -> a -> Bool)
416− -> Gen a
432+ => Gen a
417− -> ((Connection -> TestT IO ()) -> PropertyT IO b)
433+ -> (TestT Transaction () -> PropertyT IO b)
418 -> PropertyT IO b
434 -> PropertyT IO b
419− t eq generator transaction = do
435+ t generator transaction = do
420 x <- forAll generator
436 x <- forAll generator
421
437
422− transaction \connection -> do
438+ transaction do
439+ [res] <- lift do
440+ statement () $ Rel8.select do
423− [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x)
441+ pure (Rel8.litExpr x)
424− diff res eq x
442+ diff res (==) x
425
443
426 genDay :: Gen Day
444 genDay :: Gen Day
427 genDay = do
445 genDay = do
@@ -463,13 +481,15 @@ testDBEq getTestDatabase = testGroup "DBEq instances"
463
481
464 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)
482 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)
465 => Gen a
483 => Gen a
466− -> ((Connection -> TestT IO ()) -> PropertyT IO ())
484+ -> (TestT Transaction () -> PropertyT IO ())
467 -> PropertyT IO ()
485 -> PropertyT IO ()
468 t generator transaction = do
486 t generator transaction = do
469 (x, y) <- forAll (liftA2 (,) generator generator)
487 (x, y) <- forAll (liftA2 (,) generator generator)
470
488
471− transaction \connection -> do
489+ transaction do
490+ [res] <- lift do
491+ statement () $ Rel8.select do
472− [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y
492+ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y
473 res === (x == y)
493 res === (x == y)
474
494
475
495
@@ -477,9 +497,10 @@ testTableEquality :: IO TmpPostgres.DB -> TestTree
477testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do
497testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do
478 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable
498 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable
479
499
480− transaction \connection -> do
500+ transaction do
501+ [eq] <- lift do
481− [eq] <- liftIO $ Rel8.select connection do
502+ statement () $ Rel8.select do
482− pure $ Rel8.lit x Rel8.==: Rel8.lit y
503+ pure $ Rel8.lit x Rel8.==: Rel8.lit y
483
504
484 eq === (x == y)
505 eq === (x == y)
485
506
@@ -488,8 +509,10 @@ testFromString :: IO TmpPostgres.DB -> TestTree
488testFromString = databasePropertyTest "FromString" \transaction -> do
509testFromString = databasePropertyTest "FromString" \transaction -> do
489 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode
510 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode
490
511
491− transaction \connection -> do
512+ transaction do
513+ [result] <- lift do
514+ statement () $ Rel8.select do
492− [result] <- liftIO $ Rel8.select connection $ pure $ fromString str
515+ pure $ fromString str
493 result === pack str
516 result === pack str
494
517
495
518
@@ -497,10 +520,11 @@ testCatMaybeTable :: IO TmpPostgres.DB -> TestTree
497testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do
520testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do
498 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
521 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
499
522
500− transaction \connection -> do
523+ transaction do
524+ selected <- lift do
501− selected <- liftIO $ Rel8.select connection do
525+ statement () $ Rel8.select do
502− testTable <- Rel8.values $ Rel8.lit <$> rows
526+ testTable <- Rel8.values $ Rel8.lit <$> rows
503− Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)
527+ Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)
504
528
505 sort selected === sort (filter testTableColumn2 rows)
529 sort selected === sort (filter testTableColumn2 rows)
506
530
@@ -509,9 +533,10 @@ testCatMaybe :: IO TmpPostgres.DB -> TestTree
509testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do
533testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do
510 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool
534 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool
511
535
512− transaction \connection -> do
536+ transaction do
513− selected <- evalM $ liftIO $ Rel8.select connection do
537+ selected <- lift do
538+ statement () $ Rel8.select do
514− Rel8.catNull =<< Rel8.values (map Rel8.lit rows)
539+ Rel8.catNull =<< Rel8.values (map Rel8.lit rows)
515
540
516 sort selected === sort (catMaybes rows)
541 sort selected === sort (catMaybes rows)
517
542
@@ -520,9 +545,10 @@ testMaybeTable :: IO TmpPostgres.DB -> TestTree
520testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do
545testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do
521 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable
546 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable
522
547
523− transaction \connection -> do
548+ transaction do
524− selected <- liftIO $ Rel8.select connection $
549+ selected <- lift do
550+ statement () $ Rel8.select do
525− Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
551+ Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
526
552
527 case rows of
553 case rows of
528 [] -> selected === [def]
554 [] -> selected === [def]
@@ -549,9 +575,10 @@ testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> eval
549 Gen.list (Range.linear 0 10) $
575 Gen.list (Range.linear 0 10) $
550 liftA2 TwoTestTables genTestTable genTestTable
576 liftA2 TwoTestTables genTestTable genTestTable
551
577
552− transaction \connection -> do
578+ transaction do
579+ selected <- lift do
553− selected <- liftIO $ Rel8.select connection do
580+ statement () $ Rel8.select do
554− Rel8.values (Rel8.lit <$> rows)
581+ Rel8.values (Rel8.lit <$> rows)
555
582
556 sort selected === sort rows
583 sort selected === sort rows
557
584
@@ -561,11 +588,12 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction
561 rows1 <- genRows
588 rows1 <- genRows
562 rows2 <- genRows
589 rows2 <- genRows
563
590
564− transaction \connection -> do
591+ transaction do
592+ selected <- lift do
565− selected <- liftIO $ Rel8.select connection do
593+ statement () $ Rel8.select do
566− as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))
594+ as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))
567− bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))
595+ bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))
568− pure $ liftA2 (,) as bs
596+ pure $ liftA2 (,) as bs
569
597
570 case (rows1, rows2) of
598 case (rows1, rows2) of
571 ([], []) -> selected === [Nothing]
599 ([], []) -> selected === [Nothing]
@@ -577,14 +605,6 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction
577 genRows = forAll do
605 genRows = forAll do
578 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
606 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
579
607
580−rollingBack
581− :: (MonadBaseControl IO m, MonadIO m)
582− => Connection -> m a -> m a
583−rollingBack connection =
584− bracket_
585− (liftIO (run (sql "BEGIN") connection))
586− (liftIO (run (sql "ROLLBACK") connection))
587−
588
608
589genTestTable :: Gen (TestTable Result)
609genTestTable :: Gen (TestTable Result)
590genTestTable = do
610genTestTable = do
@@ -597,17 +617,16 @@ testUpdate :: IO TmpPostgres.DB -> TestTree
597testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
617testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
598 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable
618 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable
599
619
600− transaction \connection -> do
620+ transaction do
601− liftIO $ Rel8.insert connection
621+ selected <- lift do
602− Rel8.Insert
622+ statement () $ Rel8.insert Rel8.Insert
603 { into = testTableSchema
623 { into = testTableSchema
604 , rows = Rel8.values $ map Rel8.lit $ Map.keys rows
624 , rows = Rel8.values $ map Rel8.lit $ Map.keys rows
605 , onConflict = Rel8.DoNothing
625 , onConflict = Rel8.DoNothing
606 , returning = pure ()
626 , returning = pure ()
607 }
627 }
608
628
609− liftIO $ Rel8.update connection
610− Rel8.Update
629+ statement () $ Rel8.update Rel8.Update
611 { target = testTableSchema
630 { target = testTableSchema
612 , from = pure ()
631 , from = pure ()
613 , set = \_ r ->
632 , set = \_ r ->
@@ -628,8 +647,8 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
628 , returning = pure ()
647 , returning = pure ()
629 }
648 }
630
649
631− selected <- liftIO $ Rel8.select connection do
650+ statement () $ Rel8.select do
632− Rel8.each testTableSchema
651+ Rel8.each testTableSchema
633
652
634 sort selected === sort (Map.elems rows)
653 sort selected === sort (Map.elems rows)
635
654
@@ -642,26 +661,26 @@ testDelete :: IO TmpPostgres.DB -> TestTree
642testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do
661testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do
643 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable
662 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable
644
663
645− transaction \connection -> do
664+ transaction do
646− liftIO $ Rel8.insert connection
665+ (deleted, selected) <- lift do
647− Rel8.Insert
666+ statement () $ Rel8.insert Rel8.Insert
648 { into = testTableSchema
667 { into = testTableSchema
649 , rows = Rel8.values $ map Rel8.lit rows
668 , rows = Rel8.values $ map Rel8.lit rows
650 , onConflict = Rel8.DoNothing
669 , onConflict = Rel8.DoNothing
651 , returning = pure ()
670 , returning = pure ()
652 }
671 }
653
672
654− deleted <-
655− liftIO $ Rel8.delete connection
656− Rel8.Delete
673+ deleted <- statement () $ Rel8.delete Rel8.Delete
657 { from = testTableSchema
674 { from = testTableSchema
658 , using = pure ()
675 , using = pure ()
659 , deleteWhere = const testTableColumn2
676 , deleteWhere = const testTableColumn2
660 , returning = Rel8.Projection id
677 , returning = Rel8.Projection id
661 }
678 }
662
679
663− selected <- liftIO $ Rel8.select connection do
680+ selected <- statement () $ Rel8.select do
664− Rel8.each testTableSchema
681+ Rel8.each testTableSchema
682+
683+ pure (deleted, selected)
665
684
666 sort (deleted <> selected) === sort rows
685 sort (deleted <> selected) === sort rows
667
686
@@ -679,9 +698,10 @@ testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree
679testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do
698testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do
680 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable
699 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable
681
700
682− transaction \connection -> do
701+ transaction do
702+ selected <- lift do
683− selected <- liftIO $ Rel8.select connection do
703+ statement () $ Rel8.select do
684− Rel8.values $ map Rel8.lit rows
704+ Rel8.values $ map Rel8.lit rows
685
705
686 sort selected === sort rows
706 sort selected === sort rows
687
707
@@ -690,18 +710,20 @@ testSelectArray :: IO TmpPostgres.DB -> TestTree
690testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do
710testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do
691 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool
711 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool
692
712
693− transaction \connection -> do
713+ transaction do
714+ selected <- lift do
694− selected <- liftIO $ Rel8.select connection do
715+ statement () $ Rel8.select do
695− Rel8.many $ Rel8.values (map Rel8.lit rows)
716+ Rel8.many $ Rel8.values (map Rel8.lit rows)
696
717
697 selected === [foldMap pure rows]
718 selected === [foldMap pure rows]
698
719
720+ selected' <- lift do
699− selected' <- liftIO $ Rel8.select connection $ do
721+ statement () $ Rel8.select do
700− a <- Rel8.catListTable =<< do
722+ a <- Rel8.catListTable =<< do
701− Rel8.many $ Rel8.values (map Rel8.lit rows)
723+ Rel8.many $ Rel8.values (map Rel8.lit rows)
702− b <- Rel8.catListTable =<< do
724+ b <- Rel8.catListTable =<< do
703− Rel8.many $ Rel8.values (map Rel8.lit rows)
725+ Rel8.many $ Rel8.values (map Rel8.lit rows)
704− pure (a, b)
726+ pure (a, b)
705
727
706 selected' === liftA2 (,) rows rows
728 selected' === liftA2 (,) rows rows
707
729
@@ -723,10 +745,11 @@ testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree
723testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do
745testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do
724 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }
746 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }
725
747
726− transaction \connection -> do
748+ transaction do
749+ selected <- lift do
727− selected <- liftIO $ Rel8.select connection do
750+ statement () $ Rel8.select do
728− x <- Rel8.values [Rel8.lit example]
751+ x <- Rel8.values [Rel8.lit example]
729− pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
752+ pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
730
753
731 selected === [True]
754 selected === [True]
732
755
@@ -734,11 +757,12 @@ testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other ta
734testEvaluate :: IO TmpPostgres.DB -> TestTree
757testEvaluate :: IO TmpPostgres.DB -> TestTree
735testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do
758testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do
736
759
737− transaction \connection -> do
760+ transaction do
761+ selected <- lift do
738− selected <- liftIO $ Rel8.select connection do
762+ statement () $ Rel8.select do
739− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
763+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
740− y <- Rel8.evaluate (Rel8.nextval "test_seq")
764+ y <- Rel8.evaluate (Rel8.nextval "test_seq")
741− pure (x, (y, y))
765+ pure (x, (y, y))
742
766
743 normalize selected ===
767 normalize selected ===
744 [ ('a', (0, 0))
768 [ ('a', (0, 0))
@@ -746,11 +770,12 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect
746 , ('c', (2, 2))
770 , ('c', (2, 2))
747 ]
771 ]
748
772
773+ selected' <- lift do
749− selected' <- liftIO $ Rel8.select connection do
774+ statement () $ Rel8.select do
750− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
775+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
751− y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
776+ y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
752− z <- Rel8.evaluate (Rel8.nextval "test_seq")
777+ z <- Rel8.evaluate (Rel8.nextval "test_seq")
753− pure ((x, y), (z, z))
778+ pure ((x, y), (z, z))
754
779
755 normalize selected' ===
780 normalize selected' ===
756 [ (('a', 'd'), (0, 0))
781 [ (('a', 'd'), (0, 0))
@@ -768,13 +793,3 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect
768 normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]
793 normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]
769 normalize [] = []
794 normalize [] = []
770 normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs
795 normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs
771−
772−{-
773− selected <- liftIO $ Rel8.select connection do
774− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
775− x <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
776− y <- Rel8.evaluate (Rel8.nextval "test_seq")
777− pure (x, y, y)
778−
779− selected === [('a', 1, 1), ('b', 2, 2), ('c', 3, 3)]
780−-}