git.iko.soy/rowtype-yoga/purescript-yoga-postgres
on main help sign in
swap
c39795328 ahead, 0 behind
.github/workflows/ci.yml+6−1
since splitsnapshots
unifiedsplit
@@ -6,4 +6,9 @@ jobs:
6 steps:
6 steps:
7 - uses: actions/checkout@v4
7 - uses: actions/checkout@v4
8 - uses: rowtype-yoga/purescript-yoga-actions/.github/actions/setup@main
8 - uses: rowtype-yoga/purescript-yoga-actions/.github/actions/setup@main
9+ - run: bun install --frozen-lockfile
10+ - run: docker compose -f docker-compose.test.yml up -d --wait postgres
9− - run: spago build
11+ - run: spago test
12+ - run: bash compile-fail-tests/run.sh
13+ - if: always()
14+ run: docker compose -f docker-compose.test.yml down --volumes
.gitignore+1
@@ -3,3 +3,4 @@ node_modules/
3output/
3output/
4output-*/
4output-*/
5.DS_Store
5.DS_Store
6+.psc-ide-port
.psc-ide-port+1−1
@@ -1 +1 @@
1−15245
1+15490
bun.lock+3
@@ -6,6 +6,7 @@
6 "dependencies": {
6 "dependencies": {
7 "pg": "^8.11.0",
7 "pg": "^8.11.0",
8 "postgres": "^3.4.8",
8 "postgres": "^3.4.8",
9+ "uuid": "^13.0.0",
9 },
10 },
10 },
11 },
11 },
12 },
@@ -38,6 +39,8 @@
38
39
39 "split2": ["split2@4.2.0", "", {}, "sha512-UcjcJOWknrNkF6PLX83qcHM6KHgVKNkV62Y8a5uYDVv9ydGQVwAHMKqHdJje1VTWpljG0WYpCDhrCdAOYH4TWg=="],
40 "split2": ["split2@4.2.0", "", {}, "sha512-UcjcJOWknrNkF6PLX83qcHM6KHgVKNkV62Y8a5uYDVv9ydGQVwAHMKqHdJje1VTWpljG0WYpCDhrCdAOYH4TWg=="],
40
41
42+ "uuid": ["uuid@13.0.0", "", { "bin": { "uuid": "dist-node/bin/uuid" } }, "sha512-XQegIaBTVUjSHliKqcnFqYypAd4S+WCYt5NIeRs6w/UAry7z8Y9j5ZwRRL4kzq9U3sD6v+85er9FvkEaBpji2w=="],
43+
41 "xtend": ["xtend@4.0.2", "", {}, "sha512-LKYU1iAXJXUgAXn9URjiu+MWhyUXHsvfp7mcuYm9dSUKK0/CjtrUwFAxD82/mCWbtLsGjFIad0wIsod4zrTAEQ=="],
44 "xtend": ["xtend@4.0.2", "", {}, "sha512-LKYU1iAXJXUgAXn9URjiu+MWhyUXHsvfp7mcuYm9dSUKK0/CjtrUwFAxD82/mCWbtLsGjFIad0wIsod4zrTAEQ=="],
42 }
45 }
43}
46}
compile-fail-tests/EmptyWhere.pursnew file+20
@@ -0,0 +1,20 @@
1+-- EXPECT: Empty WHERE clause
2+module Test.CompileFail.EmptyWhere where
3+
4+import Prelude
5+import Data.Maybe (Maybe(..))
6+import Type.Function (type (#))
7+import Type.Proxy (Proxy(..))
8+import Yoga.Postgres.Schema
9+
10+type UsersTable = Table "users"
11+ ( id :: Int # PrimaryKey # AutoIncrement
12+ , name :: String
13+ , email :: String # Unique
14+ , age :: Maybe Int
15+ )
16+
17+usersTable :: Proxy UsersTable
18+usersTable = Proxy
19+
20+bad = from usersTable # selectAll # where_ @""
compile-fail-tests/InvalidLimitDecimal.pursnew file+20
@@ -0,0 +1,20 @@
1+-- EXPECT: LIMIT/OFFSET must be a non-negative integer or $parameter
2+module Test.CompileFail.InvalidLimitDecimal where
3+
4+import Prelude
5+import Data.Maybe (Maybe(..))
6+import Type.Function (type (#))
7+import Type.Proxy (Proxy(..))
8+import Yoga.Postgres.Schema
9+
10+type UsersTable = Table "users"
11+ ( id :: Int # PrimaryKey # AutoIncrement
12+ , name :: String
13+ , email :: String # Unique
14+ , age :: Maybe Int
15+ )
16+
17+usersTable :: Proxy UsersTable
18+usersTable = Proxy
19+
20+bad = from usersTable # selectAll # limit @"10.5"
compile-fail-tests/InvalidLimitNegative.pursnew file+20
@@ -0,0 +1,20 @@
1+-- EXPECT: LIMIT/OFFSET must be a non-negative integer or $parameter
2+module Test.CompileFail.InvalidLimitNegative where
3+
4+import Prelude
5+import Data.Maybe (Maybe(..))
6+import Type.Function (type (#))
7+import Type.Proxy (Proxy(..))
8+import Yoga.Postgres.Schema
9+
10+type UsersTable = Table "users"
11+ ( id :: Int # PrimaryKey # AutoIncrement
12+ , name :: String
13+ , email :: String # Unique
14+ , age :: Maybe Int
15+ )
16+
17+usersTable :: Proxy UsersTable
18+usersTable = Proxy
19+
20+bad = from usersTable # selectAll # limit @"-5"
compile-fail-tests/InvalidLimitNonNumeric.pursnew file+20
@@ -0,0 +1,20 @@
1+-- EXPECT: LIMIT/OFFSET must be a non-negative integer or $parameter
2+module Test.CompileFail.InvalidLimitNonNumeric where
3+
4+import Prelude
5+import Data.Maybe (Maybe(..))
6+import Type.Function (type (#))
7+import Type.Proxy (Proxy(..))
8+import Yoga.Postgres.Schema
9+
10+type UsersTable = Table "users"
11+ ( id :: Int # PrimaryKey # AutoIncrement
12+ , name :: String
13+ , email :: String # Unique
14+ , age :: Maybe Int
15+ )
16+
17+usersTable :: Proxy UsersTable
18+usersTable = Proxy
19+
20+bad = from usersTable # selectAll # limit @"abc"
compile-fail-tests/LeadingCommaInOrderBy.pursnew file+20
@@ -0,0 +1,20 @@
1+-- EXPECT: Unexpected comma in ORDER BY clause
2+module Test.CompileFail.LeadingCommaInOrderBy where
3+
4+import Prelude
5+import Data.Maybe (Maybe(..))
6+import Type.Function (type (#))
7+import Type.Proxy (Proxy(..))
8+import Yoga.Postgres.Schema
9+
10+type UsersTable = Table "users"
11+ ( id :: Int # PrimaryKey # AutoIncrement
12+ , name :: String
13+ , email :: String # Unique
14+ , age :: Maybe Int
15+ )
16+
17+usersTable :: Proxy UsersTable
18+usersTable = Proxy
19+
20+bad = from usersTable # selectAll # orderBy @",name"
compile-fail-tests/OnConflictBadExcluded.purs+3−2
@@ -1,4 +1,4 @@
1−-- EXPECT: Expected
1+-- EXPECT: TypesDoNotUnify
2module Test.CompileFail.OnConflictBadExcluded where
2module Test.CompileFail.OnConflictBadExcluded where
3
3
4import Prelude
4import Prelude
@@ -17,4 +17,5 @@ type UsersTable = Table "users"
17usersTable :: Proxy UsersTable
17usersTable :: Proxy UsersTable
18usersTable = Proxy
18usersTable = Proxy
19
19
20+-- ON CONFLICT target column must exist in the table
20−bad = from usersTable # insert { name: "A", email: "a@b.com" } # onConflict @"email" @"DO UPDATE SET name = EXCLUDED.bogus"
21+bad = from usersTable # insert { name: "A", email: "a@b.com" } # onConflict @"bogus_column" @"DO UPDATE SET name = EXCLUDED.name"
compile-fail-tests/OrderByOnlyModifier.pursnew file+20
@@ -0,0 +1,20 @@
1+-- EXPECT: ORDER BY requires a column name before ASC/DESC
2+module Test.CompileFail.OrderByOnlyModifier where
3+
4+import Prelude
5+import Data.Maybe (Maybe(..))
6+import Type.Function (type (#))
7+import Type.Proxy (Proxy(..))
8+import Yoga.Postgres.Schema
9+
10+type UsersTable = Table "users"
11+ ( id :: Int # PrimaryKey # AutoIncrement
12+ , name :: String
13+ , email :: String # Unique
14+ , age :: Maybe Int
15+ )
16+
17+usersTable :: Proxy UsersTable
18+usersTable = Proxy
19+
20+bad = from usersTable # selectAll # orderBy @"ASC"
compile-fail-tests/ReturningWithoutMutation.pursnew file+17
@@ -0,0 +1,17 @@
1+-- EXPECT: RETURNING requires a preceding INSERT, UPDATE (set), or DELETE
2+module Test.CompileFail.ReturningWithoutMutation where
3+
4+import Prelude
5+import Type.Function (type (#))
6+import Type.Proxy (Proxy(..))
7+import Yoga.Postgres.Schema
8+
9+type UsersTable = Table "users"
10+ ( id :: Int # PrimaryKey # AutoIncrement
11+ , name :: String
12+ )
13+
14+usersTable :: Proxy UsersTable
15+usersTable = Proxy
16+
17+bad = from usersTable # returning @"id"
compile-fail-tests/TrailingCommaInOrderBy.pursnew file+20
@@ -0,0 +1,20 @@
1+-- EXPECT: Trailing comma in ORDER BY clause
2+module Test.CompileFail.TrailingCommaInOrderBy where
3+
4+import Prelude
5+import Data.Maybe (Maybe(..))
6+import Type.Function (type (#))
7+import Type.Proxy (Proxy(..))
8+import Yoga.Postgres.Schema
9+
10+type UsersTable = Table "users"
11+ ( id :: Int # PrimaryKey # AutoIncrement
12+ , name :: String
13+ , email :: String # Unique
14+ , age :: Maybe Int
15+ )
16+
17+usersTable :: Proxy UsersTable
18+usersTable = Proxy
19+
20+bad = from usersTable # selectAll # orderBy @"name,"
compile-fail-tests/UnclosedStringLiteral.pursnew file+20
@@ -0,0 +1,20 @@
1+-- EXPECT: Unclosed string literal
2+module Test.CompileFail.UnclosedStringLiteral where
3+
4+import Prelude
5+import Data.Maybe (Maybe(..))
6+import Type.Function (type (#))
7+import Type.Proxy (Proxy(..))
8+import Yoga.Postgres.Schema
9+
10+type UsersTable = Table "users"
11+ ( id :: Int # PrimaryKey # AutoIncrement
12+ , name :: String
13+ , email :: String # Unique
14+ , age :: Maybe Int
15+ )
16+
17+usersTable :: Proxy UsersTable
18+usersTable = Proxy
19+
20+bad = from usersTable # selectAll # where_ @"name = 'unclosed"
compile-fail-tests/UnclosedStringLiteralJoin.pursnew file+29
@@ -0,0 +1,29 @@
1+-- EXPECT: Unclosed string literal
2+module Test.CompileFail.UnclosedStringLiteralJoin where
3+
4+import Prelude
5+import Data.Maybe (Maybe(..))
6+import Type.Function (type (#))
7+import Type.Proxy (Proxy(..))
8+import Yoga.Postgres.Schema
9+
10+type UsersTable = Table "users"
11+ ( id :: Int # PrimaryKey # AutoIncrement
12+ , name :: String
13+ , email :: String # Unique
14+ , age :: Maybe Int
15+ )
16+
17+type PostsTable = Table "posts"
18+ ( id :: Int # PrimaryKey # AutoIncrement
19+ , user_id :: Int
20+ , title :: String
21+ )
22+
23+usersTable :: Proxy UsersTable
24+usersTable = Proxy
25+
26+postsTable :: Proxy PostsTable
27+postsTable = Proxy
28+
29+bad = from usersTable # select @"users.name" # innerJoin @"users.id = 'unclosed" postsTable
docker-compose.test.ymlnew file+14
@@ -0,0 +1,14 @@
1+services:
2+ postgres:
3+ image: postgres:17
4+ environment:
5+ POSTGRES_USER: postgres
6+ POSTGRES_PASSWORD: postgres
7+ POSTGRES_DB: test_playground
8+ ports:
9+ - "5434:5432"
10+ healthcheck:
11+ test: ["CMD-SHELL", "pg_isready -U postgres"]
12+ interval: 2s
13+ timeout: 5s
14+ retries: 10
package.json+2−1
@@ -25,6 +25,7 @@
25 },
25 },
26 "dependencies": {
26 "dependencies": {
27 "pg": "^8.11.0",
27 "pg": "^8.11.0",
28− "postgres": "^3.4.8"
28+ "postgres": "^3.4.8",
29+ "uuid": "^13.0.0"
29 }
30 }
30}
31}
spago.lock+64−15
@@ -6,7 +6,10 @@
6 "core": {
6 "core": {
7 "dependencies": [
7 "dependencies": [
8 {
8 {
9+ "aff": ">=8.0.0 <9.0.0"
10+ },
11+ {
9− "aff": ">=7.1.0 <8.0.0"
12+ "arrays": ">=7.3.0 <8.0.0"
10 },
13 },
11 {
14 {
12 "datetime": ">=6.1.0 <7.0.0"
15 "datetime": ">=6.1.0 <7.0.0"
@@ -17,6 +20,12 @@
17 {
20 {
18 "either": ">=6.1.0 <7.0.0"
21 "either": ">=6.1.0 <7.0.0"
19 },
22 },
23+ {
24+ "enums": ">=6.0.1 <7.0.0"
25+ },
26+ {
27+ "exceptions": ">=6.1.0 <7.0.0"
28+ },
20 {
29 {
21 "foldable-traversable": ">=6.0.0 <7.0.0"
30 "foldable-traversable": ">=6.0.0 <7.0.0"
22 },
31 },
@@ -24,7 +33,16 @@
24 "foreign": ">=7.0.0 <8.0.0"
33 "foreign": ">=7.0.0 <8.0.0"
25 },
34 },
26 {
35 {
27− "heterogeneous": ">=0.6.0 <0.7.0"
36+ "heterogeneous": ">=0.7.0 <0.8.0"
37+ },
38+ {
39+ "integers": ">=6.0.0 <7.0.0"
40+ },
41+ {
42+ "js-bigints": ">=2.2.1 <3.0.0"
43+ },
44+ {
45+ "js-date": ">=8.0.0 <9.0.0"
28 },
46 },
29 {
47 {
30 "js-promise": ">=1.0.0 <2.0.0"
48 "js-promise": ">=1.0.0 <2.0.0"
@@ -32,6 +50,9 @@
32 {
50 {
33 "js-promise-aff": ">=1.0.0 <2.0.0"
51 "js-promise-aff": ">=1.0.0 <2.0.0"
34 },
52 },
53+ {
54+ "lists": ">=7.0.0 <8.0.0"
55+ },
35 {
56 {
36 "maybe": ">=6.0.0 <7.0.0"
57 "maybe": ">=6.0.0 <7.0.0"
37 },
58 },
@@ -41,20 +62,38 @@
41 {
62 {
42 "nullable": ">=6.0.0 <7.0.0"
63 "nullable": ">=6.0.0 <7.0.0"
43 },
64 },
65+ {
66+ "numbers": ">=9.0.1 <10.0.0"
67+ },
44 {
68 {
45 "ordered-collections": ">=3.2.0 <4.0.0"
69 "ordered-collections": ">=3.2.0 <4.0.0"
46 },
70 },
47 {
71 {
48 "prelude": ">=6.0.2 <7.0.0"
72 "prelude": ">=6.0.2 <7.0.0"
49 },
73 },
74+ {
75+ "record": ">=4.0.0 <5.0.0"
76+ },
77+ {
78+ "strings": ">=6.0.1 <7.0.0"
79+ },
80+ {
81+ "transformers": ">=6.1.0 <7.0.0"
82+ },
83+ {
84+ "typelevel-prelude": ">=7.0.0 <8.0.0"
85+ },
50 {
86 {
51 "unsafe-coerce": ">=6.0.0 <7.0.0"
87 "unsafe-coerce": ">=6.0.0 <7.0.0"
52 },
88 },
53 {
89 {
54− "yoga-json": ">=5.2.0 <6.0.0"
90+ "uuid": ">=9.0.0 <10.0.0"
55 },
91 },
56 {
92 {
93+ "yoga-json": ">=5.2.1 <6.0.0"
94+ },
95+ {
57− "yoga-sql-types": ">=0.1.0 <0.2.0"
96+ "yoga-sql-types": ">=0.2.0 <0.3.0"
58 }
97 }
59 ]
98 ]
60 },
99 },
@@ -84,8 +123,8 @@
84 "packages": {
123 "packages": {
85 "aff": {
124 "aff": {
86 "type": "registry",
125 "type": "registry",
87− "version": "7.1.0",
126+ "version": "8.0.0",
88− "integrity": "sha256-/nOpDQVnKIoP1pQ1ZZBYpadK0TuMlG4WwufGzJpsfD0=",
127+ "integrity": "sha256-9BRIrSdRoYybfiUmBqgKJ66cPqxYHb277bVWQMn/9sg=",
89 "dependencies": [
128 "dependencies": [
90 "control",
129 "control",
91 "datetime",
130 "datetime",
@@ -436,8 +475,8 @@
436 },
475 },
437 "heterogeneous": {
476 "heterogeneous": {
438 "type": "registry",
477 "type": "registry",
439− "version": "0.6.0",
478+ "version": "0.7.0",
440− "integrity": "sha256-nQgk2iHYe5LIi6ZzREgWaCU3y8oCwdhDSukT6xVMWdk=",
479+ "integrity": "sha256-pQwcFvhWL8noktxaoD7FlLs2F2lYf3QHoyO0VOWO3I0=",
441 "dependencies": [
480 "dependencies": [
442 "either",
481 "either",
443 "foldable-traversable",
482 "foldable-traversable",
@@ -916,6 +955,16 @@
916 "integrity": "sha256-0L1QsaY20OILjfU5TV72d3U/tSjhmL9hJ32WMp857Lk=",
955 "integrity": "sha256-0L1QsaY20OILjfU5TV72d3U/tSjhmL9hJ32WMp857Lk=",
917 "dependencies": []
956 "dependencies": []
918 },
957 },
958+ "uuid": {
959+ "type": "registry",
960+ "version": "9.0.0",
961+ "integrity": "sha256-aM/9+7xlHs5UDdtRfoEQosPpYOruwowa3sezIodJ3vk=",
962+ "dependencies": [
963+ "effect",
964+ "maybe",
965+ "prelude"
966+ ]
967+ },
919 "variant": {
968 "variant": {
920 "type": "registry",
969 "type": "registry",
921 "version": "8.0.0",
970 "version": "8.0.0",
@@ -934,8 +983,8 @@
934 },
983 },
935 "yoga-json": {
984 "yoga-json": {
936 "type": "registry",
985 "type": "registry",
937− "version": "5.2.0",
986+ "version": "5.2.1",
938− "integrity": "sha256-M+kkz6E1Gf+C4bKnhqoBFIoVcc74loi3rLULePbB204=",
987+ "integrity": "sha256-12I7qIf27oKV/D/YRcHtGpN8n7GQ0Bm3uzvI4ZjOQrs=",
939 "dependencies": [
988 "dependencies": [
940 "arrays",
989 "arrays",
941 "bifunctors",
990 "bifunctors",
@@ -973,8 +1022,8 @@
973 },
1022 },
974 "yoga-sql-types": {
1023 "yoga-sql-types": {
975 "type": "registry",
1024 "type": "registry",
976− "version": "0.1.0",
1025+ "version": "0.2.0",
977− "integrity": "sha256-vxOgnj3HK8F5gRHCNkIPNirORQtCBEKozG+CnrHtB84=",
1026+ "integrity": "sha256-/fiSiEmSQ8UH2N7vp/E02Eo+Krbs6iGcre9haDV34Q8=",
978 "dependencies": [
1027 "dependencies": [
979 "arrays",
1028 "arrays",
980 "bifunctors",
1029 "bifunctors",
@@ -1002,13 +1051,13 @@
1002 },
1051 },
1003 "yoga-test-docker": {
1052 "yoga-test-docker": {
1004 "type": "registry",
1053 "type": "registry",
1005− "version": "0.1.0",
1054+ "version": "0.1.2",
1006− "integrity": "sha256-fTd7UZ1W4w3R7sY2OJhoiFqf6Ma6ycQM/4lq9dQnkgs=",
1055+ "integrity": "sha256-J/jgHvvwb04ZOhicRGucmrQhaokrYTc9XJ2dutsktq8=",
1007 "dependencies": [
1056 "dependencies": [
1008 "aff",
1057 "aff",
1009 "datetime",
1058 "datetime",
1010− "effect",
1011 "exceptions",
1059 "exceptions",
1060+ "newtype",
1012 "prelude"
1061 "prelude"
1013 ]
1062 ]
1014 },
1063 },
spago.yaml+18−5
@@ -3,29 +3,42 @@ workspace: {}
3package:
3package:
4 name: yoga-postgres
4 name: yoga-postgres
5 publish:
5 publish:
6− version: 0.1.0
6+ version: 0.3.2
7 license: MIT
7 license: MIT
8 location:
8 location:
9 githubOwner: rowtype-yoga
9 githubOwner: rowtype-yoga
10 githubRepo: purescript-yoga-postgres
10 githubRepo: purescript-yoga-postgres
11 dependencies:
11 dependencies:
12+ - aff: ">=8.0.0 <9.0.0"
12− - aff: ">=7.1.0 <8.0.0"
13+ - arrays: ">=7.3.0 <8.0.0"
13 - datetime: ">=6.1.0 <7.0.0"
14 - datetime: ">=6.1.0 <7.0.0"
14 - effect: ">=4.0.0 <5.0.0"
15 - effect: ">=4.0.0 <5.0.0"
15 - either: ">=6.1.0 <7.0.0"
16 - either: ">=6.1.0 <7.0.0"
17+ - enums: ">=6.0.1 <7.0.0"
18+ - exceptions: ">=6.1.0 <7.0.0"
16 - foldable-traversable: ">=6.0.0 <7.0.0"
19 - foldable-traversable: ">=6.0.0 <7.0.0"
17 - foreign: ">=7.0.0 <8.0.0"
20 - foreign: ">=7.0.0 <8.0.0"
18− - heterogeneous: ">=0.6.0 <0.7.0"
21+ - heterogeneous: ">=0.7.0 <0.8.0"
22+ - integers: ">=6.0.0 <7.0.0"
23+ - js-bigints: ">=2.2.1 <3.0.0"
24+ - js-date: ">=8.0.0 <9.0.0"
19 - js-promise: ">=1.0.0 <2.0.0"
25 - js-promise: ">=1.0.0 <2.0.0"
20 - js-promise-aff: ">=1.0.0 <2.0.0"
26 - js-promise-aff: ">=1.0.0 <2.0.0"
27+ - lists: ">=7.0.0 <8.0.0"
21 - maybe: ">=6.0.0 <7.0.0"
28 - maybe: ">=6.0.0 <7.0.0"
22 - newtype: ">=5.0.0 <6.0.0"
29 - newtype: ">=5.0.0 <6.0.0"
23 - nullable: ">=6.0.0 <7.0.0"
30 - nullable: ">=6.0.0 <7.0.0"
31+ - numbers: ">=9.0.1 <10.0.0"
24 - ordered-collections: ">=3.2.0 <4.0.0"
32 - ordered-collections: ">=3.2.0 <4.0.0"
25 - prelude: ">=6.0.2 <7.0.0"
33 - prelude: ">=6.0.2 <7.0.0"
34+ - record: ">=4.0.0 <5.0.0"
35+ - strings: ">=6.0.1 <7.0.0"
36+ - transformers: ">=6.1.0 <7.0.0"
37+ - typelevel-prelude: ">=7.0.0 <8.0.0"
26 - unsafe-coerce: ">=6.0.0 <7.0.0"
38 - unsafe-coerce: ">=6.0.0 <7.0.0"
39+ - uuid: ">=9.0.0 <10.0.0"
27− - yoga-json: ">=5.2.0 <6.0.0"
40+ - yoga-json: ">=5.2.1 <6.0.0"
28− - yoga-sql-types: ">=0.1.0 <0.2.0"
41+ - yoga-sql-types: ">=0.2.0 <0.3.0"
29 test:
42 test:
30 main: Test.Postgres.Main
43 main: Test.Postgres.Main
31 dependencies:
44 dependencies:
src/Yoga/Postgres.js+42−42
@@ -2,27 +2,20 @@ import postgres from 'postgres';
2
2
3// Create Postgres connection
3// Create Postgres connection
4export const postgresImpl = (config) => {
4export const postgresImpl = (config) => {
5− // Support both individual config and connection string
5+ const { connection, ...configOptions } = config;
6− if (config.connection) {
6+ const options = {
7− return postgres(config.connection, config);
7+ ...configOptions,
8− }
8+ onnotice: config.onnotice
9−
10− return postgres({
11− host: config.host,
12− port: config.port,
13− database: config.database,
14− username: config.username,
15− password: config.password,
16− max: config.max,
9+ ? () => config.onnotice()
17− idle_timeout: config.idle_timeout,
10+ : undefined,
18− connect_timeout: config.connect_timeout,
11+ onparameter: config.onparameter
19− ssl: config.ssl,
12+ ? (key, value) => config.onparameter({ key, value })()
20− debug: config.debug,
13+ : undefined
21− onnotice: config.onnotice,
14+ };
22− onparameter: config.onparameter,
15+
23− // Pass through any other options
16+ return connection
24− ...config
17+ ? postgres(connection, options)
25− });
18+ : postgres(options);
26};
19};
27
20
28// Query operations
21// Query operations
@@ -92,27 +85,29 @@ export const beginImpl = async (sql) => {
92};
85};
93
86
94export const commitImpl = async (txn) => {
87export const commitImpl = async (txn) => {
95− if (txn._reserved) {
88+ if (!txn._reserved) return;
89+
90+ const reserved = txn._reserved;
91+ txn._reserved = null;
92+ try {
96− await txn._reserved`COMMIT`;
93+ await reserved`COMMIT`;
97− // Release the connection back to the pool
94+ } finally {
98− await txn._reserved.release();
95+ await reserved.release();
99 }
96 }
100};
97};
101
98
102export const rollbackImpl = async (txn) => {
99export const rollbackImpl = async (txn) => {
103− if (txn._reserved) {
100+ if (!txn._reserved) return;
101+
102+ const reserved = txn._reserved;
103+ txn._reserved = null;
104+ try {
104− await txn._reserved`ROLLBACK`;
105+ await reserved`ROLLBACK`;
105− // Release the connection back to the pool
106+ } finally {
106− await txn._reserved.release();
107+ await reserved.release();
107 }
108 }
108};
109};
109
110
110−export const transactionImpl = async (sql, handler) => {
111− return sql.begin(async (txn) => {
112− const affAction = handler(txn);
113− return await affAction();
114− });
115−};
116
111
117export const txQueryImpl = async (txn, queryString, params) => {
112export const txQueryImpl = async (txn, queryString, params) => {
118 // Use the underlying SQL connection
113 // Use the underlying SQL connection
@@ -147,19 +142,24 @@ export const endImpl = (sql) => sql.end();
147
142
148// Listen/Notify
143// Listen/Notify
149
144
145+const listeners = new WeakMap();
146+
150export const listenImpl = async (sql, channel, handler) => {
147export const listenImpl = async (sql, channel, handler) => {
151− await sql.listen(channel, (payload) => {
148+ const subscription = await sql.listen(channel, (payload) => {
152 handler({ channel, payload })();
149 handler({ channel, payload })();
153 });
150 });
151+ const byChannel = listeners.get(sql) || new Map();
152+ const subscriptions = byChannel.get(channel) || [];
153+ subscriptions.push(subscription);
154+ byChannel.set(channel, subscriptions);
155+ listeners.set(sql, byChannel);
154};
156};
155
157
156export const unlistenImpl = async (sql, channel) => {
158export const unlistenImpl = async (sql, channel) => {
157− // postgres.js uses the same listen method to unlisten
159+ const byChannel = listeners.get(sql);
158− if (sql.listen.unlisten) {
160+ const subscriptions = byChannel?.get(channel) || [];
159− return sql.listen.unlisten(channel);
161+ await Promise.all(subscriptions.map(({ unlisten }) => unlisten()));
160− }
162+ byChannel?.delete(channel);
161− // Alternative: just resolve, as postgres.js handles cleanup automatically
162− return Promise.resolve();
163};
163};
164
164
165export const notifyImpl = (sql, channel, payload) =>
165export const notifyImpl = (sql, channel, payload) =>
src/Yoga/Postgres.purs+18−8
@@ -2,18 +2,22 @@ module Yoga.Postgres where
2
2
3import Prelude
3import Prelude
4
4
5+
6+
5import Data.Maybe (Maybe)
7import Data.Maybe (Maybe)
6import Data.Newtype (class Newtype)
8import Data.Newtype (class Newtype)
7import Data.Nullable (Nullable)
9import Data.Nullable (Nullable)
8import Data.Nullable as Nullable
10import Data.Nullable as Nullable
9import Data.Time.Duration (Milliseconds)
11import Data.Time.Duration (Milliseconds)
12+import Data.UUID (UUID)
13+import Data.UUID as UUID
10import Effect (Effect)
14import Effect (Effect)
11−import Effect.Aff (Aff)
15+import Effect.Aff (Aff, generalBracket)
12import Effect.Uncurried (EffectFn1, EffectFn2, EffectFn3, runEffectFn1, runEffectFn2, runEffectFn3)
16import Effect.Uncurried (EffectFn1, EffectFn2, EffectFn3, runEffectFn1, runEffectFn2, runEffectFn3)
13import Foreign (Foreign)
17import Foreign (Foreign)
14import Prim.Row (class Union)
18import Prim.Row (class Union)
15import Promise (Promise)
19import Promise (Promise)
16−import Promise.Aff (fromAff, toAffE) as Promise
20+import Promise.Aff (toAffE) as Promise
17import Unsafe.Coerce (unsafeCoerce)
21import Unsafe.Coerce (unsafeCoerce)
18
22
19-- Opaque Postgres types
23-- Opaque Postgres types
@@ -114,6 +118,9 @@ instance ToPGValue Boolean where
114instance ToPGValue a => ToPGValue (Array a) where
118instance ToPGValue a => ToPGValue (Array a) where
115 toPGValue arr = unsafeCoerce (map toPGValue arr)
119 toPGValue arr = unsafeCoerce (map toPGValue arr)
116
120
121+instance ToPGValue UUID where
122+ toPGValue = toPGValue <<< UUID.toString
123+
117instance ToPGValue Foreign where
124instance ToPGValue Foreign where
118 toPGValue = unsafeCoerce
125 toPGValue = unsafeCoerce
119
126
@@ -219,13 +226,16 @@ foreign import rollbackImpl :: EffectFn1 Transaction (Promise Unit)
219rollback :: Transaction -> Aff Unit
226rollback :: Transaction -> Aff Unit
220rollback = runEffectFn1 rollbackImpl >>> Promise.toAffE
227rollback = runEffectFn1 rollbackImpl >>> Promise.toAffE
221
228
222−-- Run transaction block (automatic commit/rollback)
223−foreign import transactionImpl :: EffectFn2 Connection (Transaction -> Effect (Promise Unit)) (Promise Unit)
224
229
230+-- Low-level escape hatch for code that needs the raw transaction handle.
225−transaction :: (Transaction -> Aff Unit) -> Connection -> Aff Unit
231+withTransaction :: forall a. (Transaction -> Aff a) -> Connection -> Aff a
226−transaction handler conn =
232+withTransaction operation conn =
227− runEffectFn2 transactionImpl conn (\txn -> Promise.fromAff (handler txn))
233+ generalBracket (begin conn)
228− # Promise.toAffE
234+ { killed: \_ -> rollback
235+ , failed: \_ -> rollback
236+ , completed: \_ -> commit
237+ }
238+ operation
229
239
230-- Query within transaction
240-- Query within transaction
231foreign import txQueryImpl :: EffectFn3 Transaction SQL (Array PGValue) (Promise QueryResult)
241foreign import txQueryImpl :: EffectFn3 Transaction SQL (Array PGValue) (Promise QueryResult)
src/Yoga/Postgres/Schema.purs+748−68
@@ -2,36 +2,47 @@ module Yoga.Postgres.Schema where
2
2
3import Prelude
3import Prelude
4
4
5−import Data.Array as Array
5+import Control.Monad.Except (except, runExcept)
6import Data.Array (intercalate, mapWithIndex, foldl)
6import Data.Array (intercalate, mapWithIndex, foldl)
7+import Data.Array as Array
8+import Data.Date (Date, day, month, year)
7−import Data.DateTime (DateTime)
9+import Data.DateTime (DateTime(..))
10+import Data.Either (Either(..), note)
11+import Data.Enum (fromEnum, toEnum)
12+import Data.Int as Int
8import Data.JSDate as JSDate
13import Data.JSDate as JSDate
14+import Data.List.Types (NonEmptyList)
15+import Data.Map as Map
9−import Data.Maybe (Maybe(..))
16+import Data.Maybe (Maybe(..), fromMaybe)
10import Data.Newtype (class Newtype)
17import Data.Newtype (class Newtype)
11import Data.Nullable (toNullable)
18import Data.Nullable (toNullable)
12−import JS.BigInt (BigInt)
19+import Data.Number as Number
13−import Unsafe.Coerce (unsafeCoerce)
14import Data.Reflectable (class Reflectable, reflectType)
20import Data.Reflectable (class Reflectable, reflectType)
21+import Data.String.CodeUnits as SCU
22+import Data.String.Common as Str
23+import Data.String.Pattern (Pattern(..))
15−import Data.String.Regex (regex, replace') as Regex
24+import Data.String.Regex (Regex, regex, replace') as Regex
16−import Data.String.Regex (Regex) as Regex
17import Data.String.Regex.Flags (global) as Regex
25import Data.String.Regex.Flags (global) as Regex
18−import Control.Monad.Except (runExcept)
19−import Data.Either (Either(..))
20−import Data.Map as Map
21import Data.Symbol (class IsSymbol, reflectSymbol)
26import Data.Symbol (class IsSymbol, reflectSymbol)
22−import Type.Function (type (#))
27+import Data.Time (Time(..))
28+import Data.Traversable (traverse)
29+import Data.UUID (UUID)
30+import Data.UUID as UUID
23−import Effect.Aff (Aff)
31+import Effect.Aff (Aff, throwError)
32+import Effect.Exception (error) as Exception
24−import Foreign (Foreign, unsafeToForeign)
33+import Foreign (Foreign, ForeignError(..))
34+import JS.BigInt (BigInt)
25import Prim.Boolean (True, False)
35import Prim.Boolean (True, False)
26import Prim.Row (class Cons, class Lacks, class Union, class Nub) as Row
36import Prim.Row (class Cons, class Lacks, class Union, class Nub) as Row
27−import Prim.RowList as RL
28import Prim.RowList (class RowToList)
37import Prim.RowList (class RowToList)
38+import Prim.RowList as RL
29import Prim.Symbol (class Cons, class Append) as Symbol
39import Prim.Symbol (class Cons, class Append) as Symbol
30import Prim.TypeError (class Fail, Beside, Text, Quote)
40import Prim.TypeError (class Fail, Beside, Text, Quote)
31import Record (get) as Record
41import Record (get) as Record
32import Type.Proxy (Proxy(..))
42import Type.Proxy (Proxy(..))
33import Type.RowList (class ListToRow)
43import Type.RowList (class ListToRow)
44+import Unsafe.Coerce (unsafeCoerce)
34−import Yoga.JSON (class ReadForeign, readImpl)
45+import Yoga.JSON (class ReadForeign, class WriteForeign, readImpl, writeImpl)
35import Yoga.Postgres as PG
46import Yoga.Postgres as PG
36
47
37-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
48-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
@@ -57,6 +68,9 @@ data Unique a
57
68
58data Default :: forall k. k -> Type -> Type
69data Default :: forall k. k -> Type -> Type
59data Default val a
70data Default val a
71+data DefaultExpr :: Symbol -> Type -> Type
72+data DefaultExpr expression a
73+
60
74
61data References
75data References
62
76
@@ -78,6 +92,178 @@ derive instance Newtype Jsonb _
78instance ReadForeign Jsonb where
92instance ReadForeign Jsonb where
79 readImpl = pure <<< Jsonb
93 readImpl = pure <<< Jsonb
80
94
95+instance WriteForeign Jsonb where
96+ writeImpl (Jsonb value) = value
97+
98+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
99+-- PGUUID: newtype over Data.UUID.UUID for Postgres integration
100+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
101+
102+newtype PGUUID = PGUUID UUID
103+
104+derive instance Newtype PGUUID _
105+derive newtype instance Eq PGUUID
106+derive newtype instance Ord PGUUID
107+derive newtype instance Show PGUUID
108+
109+instance ReadForeign PGUUID where
110+ readImpl f = do
111+ s :: String <- readImpl f
112+ pure (unsafeCoerce s)
113+
114+instance WriteForeign PGUUID where
115+ writeImpl (PGUUID uuid) = writeImpl (UUID.toString uuid)
116+
117+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
118+-- PGDate / PGTime: newtypes for DATE and TIME columns
119+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
120+
121+newtype PGDate = PGDate Date
122+
123+derive instance Newtype PGDate _
124+derive instance Eq PGDate
125+derive instance Ord PGDate
126+instance Show PGDate where
127+ show (PGDate d) = "(PGDate " <> show d <> ")"
128+
129+instance ReadForeign PGDate where
130+ readImpl f =
131+ except $ note (pure (ForeignError "Invalid date")) (JSDate.toDate jsDate <#> PGDate)
132+ where
133+ jsDate :: JSDate.JSDate
134+ jsDate = unsafeCoerce f
135+
136+instance WriteForeign PGDate where
137+ writeImpl (PGDate date) =
138+ writeImpl
139+ ( show (fromEnum (year date))
140+ <> "-"
141+ <> pad2 (fromEnum (month date))
142+ <> "-"
143+ <> pad2 (fromEnum (day date))
144+ )
145+ where
146+ pad2 n = if n < 10 then "0" <> show n else show n
147+
148+newtype TimestampTZ = TimestampTZ DateTime
149+
150+derive instance Newtype TimestampTZ _
151+derive instance Eq TimestampTZ
152+derive instance Ord TimestampTZ
153+instance Show TimestampTZ where
154+ show (TimestampTZ dt) = "(TimestampTZ " <> show dt <> ")"
155+
156+instance ReadForeign TimestampTZ where
157+ readImpl f =
158+ except $ note (pure (ForeignError "Invalid timestamp")) (JSDate.toDateTime jsDate <#> TimestampTZ)
159+ where
160+ jsDate :: JSDate.JSDate
161+ jsDate = unsafeCoerce f
162+
163+newtype PGTime = PGTime Time
164+
165+derive instance Newtype PGTime _
166+derive instance Eq PGTime
167+derive instance Ord PGTime
168+instance Show PGTime where
169+ show (PGTime t) = "(PGTime " <> show t <> ")"
170+
171+instance ReadForeign PGTime where
172+ readImpl f = do
173+ s :: String <- readImpl f
174+ except $ note (pure (ForeignError ("Invalid time: " <> s))) (parseTime s)
175+ where
176+ parseTime str = do
177+ let parts = Str.split (Pattern ":") str
178+ case parts of
179+ [ hStr, mStr, sStr ] -> do
180+ h <- Int.fromString hStr >>= toEnum
181+ mi <- Int.fromString mStr >>= toEnum
182+ let secParts = Str.split (Pattern ".") sStr
183+ s <- Int.fromString (fromMaybe sStr (Array.head secParts)) >>= toEnum
184+ let fraction = fromMaybe "" (Array.index secParts 1)
185+ let milliseconds = case SCU.length fraction of
186+ 0 -> "0"
187+ 1 -> fraction <> "00"
188+ 2 -> fraction <> "0"
189+ _ -> SCU.take 3 fraction
190+ let ms = fromMaybe bottom (Int.fromString milliseconds >>= toEnum)
191+ pure (PGTime (Time h mi s ms))
192+ _ -> Nothing
193+
194+instance WriteForeign PGTime where
195+ writeImpl (PGTime (Time hour minute second millisecond)) =
196+ writeImpl
197+ ( pad2 (fromEnum hour)
198+ <> ":"
199+ <> pad2 (fromEnum minute)
200+ <> ":"
201+ <> pad2 (fromEnum second)
202+ <> "."
203+ <> pad3 (fromEnum millisecond)
204+ )
205+ where
206+ pad2 n = if n < 10 then "0" <> show n else show n
207+ pad3 n
208+ | n < 10 = "00" <> show n
209+ | n < 100 = "0" <> show n
210+ | otherwise = show n
211+
212+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
213+-- Point: geometric point "(x,y)"
214+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
215+
216+newtype Point = Point { x :: Number, y :: Number }
217+
218+derive instance Newtype Point _
219+derive instance Eq Point
220+
221+instance Show Point where
222+ show (Point { x, y }) = "(Point " <> show x <> " " <> show y <> ")"
223+
224+instance ReadForeign Point where
225+ readImpl f = do
226+ s :: String <- readImpl f
227+ except $ note (pure (ForeignError ("Invalid point: " <> s))) (parsePoint s)
228+ where
229+ parsePoint str = do
230+ let inner = SCU.drop 1 (SCU.dropRight 1 str)
231+ let parts = Str.split (Pattern ",") inner
232+ case parts of
233+ [ xStr, yStr ] -> do
234+ x <- Number.fromString xStr
235+ y <- Number.fromString yStr
236+ pure (Point { x, y })
237+ _ -> Nothing
238+
239+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
240+-- TSVector / TSQuery: full-text search types
241+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
242+
243+newtype TSVector = TSVector String
244+
245+derive instance Newtype TSVector _
246+derive newtype instance Eq TSVector
247+derive newtype instance Ord TSVector
248+derive newtype instance Show TSVector
249+
250+instance ReadForeign TSVector where
251+ readImpl f = do
252+ s :: String <- readImpl f
253+ pure (TSVector s)
254+
255+newtype TSQuery = TSQuery String
256+
257+derive instance Newtype TSQuery _
258+derive newtype instance Eq TSQuery
259+derive newtype instance Ord TSQuery
260+derive newtype instance Show TSQuery
261+
262+instance ReadForeign TSQuery where
263+ readImpl f = do
264+ s :: String <- readImpl f
265+ pure (TSQuery s)
266+
81-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
267-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
82-- Nullability: inferred from Maybe
268-- Nullability: inferred from Maybe
83-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
269-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
@@ -101,6 +287,7 @@ instance ExtractType a typ => ExtractType (PrimaryKey a) typ
101else instance ExtractType a typ => ExtractType (AutoIncrement a) typ
287else instance ExtractType a typ => ExtractType (AutoIncrement a) typ
102else instance ExtractType a typ => ExtractType (Unique a) typ
288else instance ExtractType a typ => ExtractType (Unique a) typ
103else instance ExtractType a typ => ExtractType (Default val a) typ
289else instance ExtractType a typ => ExtractType (Default val a) typ
290+else instance ExtractType a typ => ExtractType (DefaultExpr expression a) typ
104else instance ExtractType a typ => ExtractType (ForeignKey t r c a) typ
291else instance ExtractType a typ => ExtractType (ForeignKey t r c a) typ
105else instance ExtractType a typ => ExtractType (Nullable a) (Maybe typ)
292else instance ExtractType a typ => ExtractType (Nullable a) (Maybe typ)
106else instance ExtractType a a
293else instance ExtractType a a
@@ -130,6 +317,27 @@ instance PGTypeName DateTime where
130instance PGTypeName BigInt where
317instance PGTypeName BigInt where
131 pgTypeName _ = "BIGINT"
318 pgTypeName _ = "BIGINT"
132
319
320+instance PGTypeName PGUUID where
321+ pgTypeName _ = "UUID"
322+
323+instance PGTypeName TimestampTZ where
324+ pgTypeName _ = "TIMESTAMPTZ"
325+
326+instance PGTypeName PGDate where
327+ pgTypeName _ = "DATE"
328+
329+instance PGTypeName PGTime where
330+ pgTypeName _ = "TIME"
331+
332+instance PGTypeName Point where
333+ pgTypeName _ = "POINT"
334+
335+instance PGTypeName TSVector where
336+ pgTypeName _ = "TSVECTOR"
337+
338+instance PGTypeName TSQuery where
339+ pgTypeName _ = "TSQUERY"
340+
133instance PGTypeName Jsonb where
341instance PGTypeName Jsonb where
134 pgTypeName _ = "JSONB"
342 pgTypeName _ = "JSONB"
135
343
@@ -152,8 +360,24 @@ instance Reflectable sym String => RenderDefaultValue sym String where
152instance Reflectable val Int => RenderDefaultValue val Int where
360instance Reflectable val Int => RenderDefaultValue val Int where
153 renderDefaultValue _ _ = "DEFAULT " <> show (reflectType (Proxy :: Proxy val))
361 renderDefaultValue _ _ = "DEFAULT " <> show (reflectType (Proxy :: Proxy val))
154
362
363+instance RenderDefaultValue True Boolean where
364+ renderDefaultValue _ _ = "DEFAULT true"
365+
155−instance Reflectable val Boolean => RenderDefaultValue val Boolean where
366+instance RenderDefaultValue False Boolean where
156− renderDefaultValue _ _ = if reflectType (Proxy :: Proxy val) then "DEFAULT true" else "DEFAULT false"
367+ renderDefaultValue _ _ = "DEFAULT false"
368+
369+instance RenderDefaultValue "true" Boolean where
370+ renderDefaultValue _ _ = "DEFAULT true"
371+
372+instance RenderDefaultValue "false" Boolean where
373+ renderDefaultValue _ _ = "DEFAULT false"
374+
375+instance RenderDefaultValue "now()" TimestampTZ where
376+ renderDefaultValue _ _ = "DEFAULT now()"
377+
378+instance RenderDefaultValue "gen_random_uuid()" PGUUID where
379+ renderDefaultValue _ _ = "DEFAULT gen_random_uuid()"
380+
157
381
158class RenderConstraint a where
382class RenderConstraint a where
159 renderConstraint :: Proxy a -> String
383 renderConstraint :: Proxy a -> String
@@ -170,6 +394,10 @@ else instance RenderConstraint a => RenderConstraint (Unique a) where
170else instance (RenderDefaultValue val a, RenderConstraint a) => RenderConstraint (Default val a) where
394else instance (RenderDefaultValue val a, RenderConstraint a) => RenderConstraint (Default val a) where
171 renderConstraint _ = joinConstraints (renderDefaultValue (Proxy :: Proxy val) (Proxy :: Proxy a)) (renderConstraint (Proxy :: Proxy a))
395 renderConstraint _ = joinConstraints (renderDefaultValue (Proxy :: Proxy val) (Proxy :: Proxy a)) (renderConstraint (Proxy :: Proxy a))
172
396
397+else instance (IsSymbol expression, RenderConstraint a) => RenderConstraint (DefaultExpr expression a) where
398+ renderConstraint _ = joinConstraints
399+ ("DEFAULT " <> reflectSymbol (Proxy :: Proxy expression))
400+ (renderConstraint (Proxy :: Proxy a))
173else instance (IsSymbol table, IsSymbol col, RenderConstraint a) => RenderConstraint (ForeignKey table References col a) where
401else instance (IsSymbol table, IsSymbol col, RenderConstraint a) => RenderConstraint (ForeignKey table References col a) where
174 renderConstraint _ = joinConstraints
402 renderConstraint _ = joinConstraints
175 ("REFERENCES " <> reflectSymbol (Proxy :: Proxy table) <> "(" <> reflectSymbol (Proxy :: Proxy col) <> ")")
403 ("REFERENCES " <> reflectSymbol (Proxy :: Proxy table) <> "(" <> reflectSymbol (Proxy :: Proxy col) <> ")")
@@ -230,6 +458,11 @@ instance
230 let columns = renderColumnsRL (Proxy :: Proxy rl)
458 let columns = renderColumnsRL (Proxy :: Proxy rl)
231 "CREATE TABLE " <> tableName <> " (" <> intercalate ", " columns <> ")"
459 "CREATE TABLE " <> tableName <> " (" <> intercalate ", " columns <> ")"
232
460
461+createTableDDLIfNotExists :: forall @a. CreateTableDDL a => String
462+createTableDDLIfNotExists = do
463+ let ddl = createTableDDL @a
464+ "CREATE TABLE IF NOT EXISTS" <> SCU.drop 12 ddl
465+
233-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
466-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
234-- INSERT SQL generation
467-- INSERT SQL generation
235-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
468-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
@@ -241,6 +474,8 @@ instance IsAutoGenerated (AutoIncrement a) where
241 isAutoGenerated _ = true
474 isAutoGenerated _ = true
242else instance IsAutoGenerated (Default v a) where
475else instance IsAutoGenerated (Default v a) where
243 isAutoGenerated _ = true
476 isAutoGenerated _ = true
477+else instance IsAutoGenerated (DefaultExpr expression a) where
478+ isAutoGenerated _ = true
244else instance IsAutoGenerated a => IsAutoGenerated (PrimaryKey a) where
479else instance IsAutoGenerated a => IsAutoGenerated (PrimaryKey a) where
245 isAutoGenerated _ = isAutoGenerated (Proxy :: Proxy a)
480 isAutoGenerated _ = isAutoGenerated (Proxy :: Proxy a)
246else instance IsAutoGenerated a => IsAutoGenerated (Unique a) where
481else instance IsAutoGenerated a => IsAutoGenerated (Unique a) where
@@ -284,15 +519,18 @@ instance
284 insertSQLFor = do
519 insertSQLFor = do
285 let tableName = reflectSymbol (Proxy :: Proxy name)
520 let tableName = reflectSymbol (Proxy :: Proxy name)
286 let cols = insertColumnsRL (Proxy :: Proxy rl)
521 let cols = insertColumnsRL (Proxy :: Proxy rl)
522+ if Array.null cols then
523+ "INSERT INTO " <> tableName <> " DEFAULT VALUES RETURNING *"
524+ else do
287− let placeholders = cols # mapWithIndex \i _ -> "$" <> show (i + 1)
525+ let placeholders = cols # mapWithIndex \i _ -> "$" <> show (i + 1)
288− "INSERT INTO " <> tableName
526+ "INSERT INTO " <> tableName
289− <> " ("
527+ <> " ("
290− <> intercalate ", " cols
528+ <> intercalate ", " cols
291− <> ")"
529+ <> ")"
292− <> " VALUES ("
530+ <> " VALUES ("
293− <> intercalate ", " placeholders
531+ <> intercalate ", " placeholders
294− <> ")"
532+ <> ")"
295− <> " RETURNING *"
533+ <> " RETURNING *"
296
534
297-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
535-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
298-- SELECT SQL generation
536-- SELECT SQL generation
@@ -415,6 +653,31 @@ class SkipSpacesGo head tail result | head tail -> result
415instance SkipSpaces tail result => SkipSpacesGo " " tail result
653instance SkipSpaces tail result => SkipSpacesGo " " tail result
416else instance Symbol.Cons head tail result => SkipSpacesGo head tail result
654else instance Symbol.Cons head tail result => SkipSpacesGo head tail result
417
655
656+-- Skip a string literal: consume chars until closing single quote
657+class SkipStringLiteral :: Symbol -> Symbol -> Constraint
658+class SkipStringLiteral sym rest | sym -> rest
659+
660+instance Fail (Text "Unclosed string literal") => SkipStringLiteral "" rest
661+else instance
662+ ( Symbol.Cons h t sym
663+ , SkipStringLiteralGo h t rest
664+ ) =>
665+ SkipStringLiteral sym rest
666+
667+class SkipStringLiteralGo :: Symbol -> Symbol -> Symbol -> Constraint
668+class SkipStringLiteralGo head tail rest | head tail -> rest
669+
670+-- Closing quote: done
671+instance SkipStringLiteralGo "'" tail tail
672+-- End of string without closing quote
673+else instance Fail (Text "Unclosed string literal") => SkipStringLiteralGo h "" rest
674+-- Any other char: skip and continue
675+else instance
676+ ( Symbol.Cons nextH nextT tail
677+ , SkipStringLiteralGo nextH nextT rest
678+ ) =>
679+ SkipStringLiteralGo h tail rest
680+
418-- Extract the first word from a Symbol (up to space or end)
681-- Extract the first word from a Symbol (up to space or end)
419class ExtractWord :: Symbol -> Symbol -> Symbol -> Constraint
682class ExtractWord :: Symbol -> Symbol -> Symbol -> Constraint
420class ExtractWord sym word rest | sym -> word rest
683class ExtractWord sym word rest | sym -> word rest
@@ -722,6 +985,15 @@ else instance
722 ) =>
985 ) =>
723 ParseSelectHandleAS "as" afterKeyword colRef tables accRL outRL
986 ParseSelectHandleAS "as" afterKeyword colRef tables accRL outRL
724
987
988+-- Bare alias (no AS keyword): "name n" means "name AS n"
989+else instance
990+ ( ResolveColumn colRef tables entry
991+ , ExtractType entry typ
992+ , SkipSpaces afterKeyword rest
993+ , ParseSelectExpectEnd rest tables (RL.Cons keyword typ accRL) outRL
994+ ) =>
995+ ParseSelectHandleAS keyword afterKeyword colRef tables accRL outRL
996+
725class ParseSelectExpectEnd :: Symbol -> Row (Row Type) -> RL.RowList Type -> RL.RowList Type -> Constraint
997class ParseSelectExpectEnd :: Symbol -> Row (Row Type) -> RL.RowList Type -> RL.RowList Type -> Constraint
726class ParseSelectExpectEnd sym tables accRL outRL | sym tables accRL -> outRL
998class ParseSelectExpectEnd sym tables accRL outRL | sym tables accRL -> outRL
727
999
@@ -820,11 +1092,66 @@ instance ResolveAggregateArg "*" tables Star
820else instance ResolveAggregateArg "" tables Star
1092else instance ResolveAggregateArg "" tables Star
821else instance
1093else instance
822 ( SkipSpaces args trimmedFront
1094 ( SkipSpaces args trimmedFront
823− , ExtractWord trimmedFront col _rest
1095+ , ExtractIdent trimmedFront col rest
824− , ResolveAggregateArgCol col tables argType
1096+ , ResolveAggregateArgDispatch col rest tables argType
825 ) =>
1097 ) =>
826 ResolveAggregateArg args tables argType
1098 ResolveAggregateArg args tables argType
827
1099
1100+-- ExtractIdent: like ExtractWord but also stops at "(" so we can detect nested function calls
1101+class ExtractIdent :: Symbol -> Symbol -> Symbol -> Constraint
1102+class ExtractIdent sym word rest | sym -> word rest
1103+
1104+instance ExtractIdent "" "" ""
1105+else instance
1106+ ( Symbol.Cons h t sym
1107+ , ExtractIdentGo h t "" word rest
1108+ ) =>
1109+ ExtractIdent sym word rest
1110+
1111+class ExtractIdentGo :: Symbol -> Symbol -> Symbol -> Symbol -> Symbol -> Constraint
1112+class ExtractIdentGo head tail acc word rest | head tail acc -> word rest
1113+
1114+instance (SkipSpaces tail rest) => ExtractIdentGo " " tail acc acc rest
1115+else instance Symbol.Cons "," tail rest => ExtractIdentGo "," tail acc acc rest
1116+else instance Symbol.Append "(" tail rest => ExtractIdentGo "(" tail acc acc rest
1117+else instance Symbol.Append acc h word => ExtractIdentGo h "" acc word ""
1118+else instance
1119+ ( Symbol.Append acc h acc'
1120+ , Symbol.Cons nextH nextT tail
1121+ , ExtractIdentGo nextH nextT acc' word rest
1122+ ) =>
1123+ ExtractIdentGo h tail acc word rest
1124+
1125+-- After extracting the identifier, check if followed by "(" (nested function call) or not (column ref)
1126+class ResolveAggregateArgDispatch :: Symbol -> Symbol -> Row (Row Type) -> Type -> Constraint
1127+class ResolveAggregateArgDispatch col rest tables argType | col rest tables -> argType
1128+
1129+instance
1130+ ResolveAggregateArgCol col tables argType =>
1131+ ResolveAggregateArgDispatch col "" tables argType
1132+
1133+else instance
1134+ ( Symbol.Cons h t rest
1135+ , ResolveAggregateArgDispatchByHead h t col tables argType
1136+ ) =>
1137+ ResolveAggregateArgDispatch col rest tables argType
1138+
1139+class ResolveAggregateArgDispatchByHead :: Symbol -> Symbol -> Symbol -> Row (Row Type) -> Type -> Constraint
1140+class ResolveAggregateArgDispatchByHead head tail col tables argType | head tail col tables -> argType
1141+
1142+-- Nested function call: col(...)
1143+instance
1144+ ( ExtractUntilParen tail innerArgs _afterParen
1145+ , ResolveAggregateArg innerArgs tables innerArgType
1146+ , AggregateReturnType col innerArgType argType
1147+ ) =>
1148+ ResolveAggregateArgDispatchByHead "(" tail col tables argType
1149+
1150+-- Not a function call: column reference
1151+else instance
1152+ ResolveAggregateArgCol col tables argType =>
1153+ ResolveAggregateArgDispatchByHead h t col tables argType
1154+
828class ResolveAggregateArgCol :: Symbol -> Row (Row Type) -> Type -> Constraint
1155class ResolveAggregateArgCol :: Symbol -> Row (Row Type) -> Type -> Constraint
829class ResolveAggregateArgCol col tables argType | col tables -> argType
1156class ResolveAggregateArgCol col tables argType | col tables -> argType
830
1157
@@ -909,8 +1236,8 @@ else instance
909class AggregateReturnTypeC :: Symbol -> Type -> Type -> Constraint
1236class AggregateReturnTypeC :: Symbol -> Type -> Type -> Constraint
910class AggregateReturnTypeC funcName argType returnType | funcName argType -> returnType
1237class AggregateReturnTypeC funcName argType returnType | funcName argType -> returnType
911
1238
912−instance AggregateReturnTypeC "COUNT" argType Int
1239+instance AggregateReturnTypeC "COUNT" argType BigInt
913−else instance AggregateReturnTypeC "count" argType Int
1240+else instance AggregateReturnTypeC "count" argType BigInt
914else instance AggregateReturnTypeC "COALESCE" argType argType
1241else instance AggregateReturnTypeC "COALESCE" argType argType
915else instance AggregateReturnTypeC "coalesce" argType argType
1242else instance AggregateReturnTypeC "coalesce" argType argType
916else instance
1243else instance
@@ -1251,7 +1578,7 @@ data NoType
1251class ParseWhere :: Symbol -> Row (Row Type) -> Row Type -> Constraint
1578class ParseWhere :: Symbol -> Row (Row Type) -> Row Type -> Constraint
1252class ParseWhere sym tables params | sym tables -> params
1579class ParseWhere sym tables params | sym tables -> params
1253
1580
1254−instance ParseWhere "" tables ()
1581+instance Fail (Text "Empty WHERE clause") => ParseWhere "" tables params
1255else instance
1582else instance
1256 ( Symbol.Cons h t sym
1583 ( Symbol.Cons h t sym
1257 , ParseWhereGo h t "" NoType tables RL.Nil outRL
1584 , ParseWhereGo h t "" NoType tables RL.Nil outRL
@@ -1277,12 +1604,19 @@ else instance (FlushWhereWord acc currentType tables paramsIn currentType' param
1277else instance (FlushWhereWord acc currentType tables paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' tables paramsOut' paramsOut) => ParseWhereGo "!" tail acc currentType tables paramsIn paramsOut
1604else instance (FlushWhereWord acc currentType tables paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' tables paramsOut' paramsOut) => ParseWhereGo "!" tail acc currentType tables paramsIn paramsOut
1278else instance (FlushWhereWord acc currentType tables paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' tables paramsOut' paramsOut) => ParseWhereGo "(" tail acc currentType tables paramsIn paramsOut
1605else instance (FlushWhereWord acc currentType tables paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' tables paramsOut' paramsOut) => ParseWhereGo "(" tail acc currentType tables paramsIn paramsOut
1279else instance (FlushWhereWord acc currentType tables paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' tables paramsOut' paramsOut) => ParseWhereGo ")" tail acc currentType tables paramsIn paramsOut
1606else instance (FlushWhereWord acc currentType tables paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' tables paramsOut' paramsOut) => ParseWhereGo ")" tail acc currentType tables paramsIn paramsOut
1607+-- String literal: flush word, skip until closing quote
1608+else instance
1280−else instance (FlushWhereWord acc currentType tables paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' tables paramsOut' paramsOut) => ParseWhereGo "'" tail acc currentType tables paramsIn paramsOut
1609+ ( FlushWhereWord acc currentType tables paramsIn currentType' paramsOut'
1610+ , SkipStringLiteral tail rest
1611+ , ParseWhereContinue rest currentType' tables paramsOut' paramsOut
1612+ ) =>
1613+ ParseWhereGo "'" tail acc currentType tables paramsIn paramsOut
1281else instance (FlushWhereWord acc currentType tables paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' tables paramsOut' paramsOut) => ParseWhereGo "@" tail acc currentType tables paramsIn paramsOut
1614else instance (FlushWhereWord acc currentType tables paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' tables paramsOut' paramsOut) => ParseWhereGo "@" tail acc currentType tables paramsIn paramsOut
1282else instance (FlushWhereWord acc currentType tables paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' tables paramsOut' paramsOut) => ParseWhereGo "?" tail acc currentType tables paramsIn paramsOut
1615else instance (FlushWhereWord acc currentType tables paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' tables paramsOut' paramsOut) => ParseWhereGo "?" tail acc currentType tables paramsIn paramsOut
1283else instance (FlushWhereWord acc currentType tables paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' tables paramsOut' paramsOut) => ParseWhereGo ":" tail acc currentType tables paramsIn paramsOut
1616else instance (FlushWhereWord acc currentType tables paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' tables paramsOut' paramsOut) => ParseWhereGo ":" tail acc currentType tables paramsIn paramsOut
1284else instance (FlushWhereWord acc currentType tables paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' tables paramsOut' paramsOut) => ParseWhereGo "~" tail acc currentType tables paramsIn paramsOut
1617else instance (FlushWhereWord acc currentType tables paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' tables paramsOut' paramsOut) => ParseWhereGo "~" tail acc currentType tables paramsIn paramsOut
1285else instance (FlushWhereWord acc currentType tables paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' tables paramsOut' paramsOut) => ParseWhereGo "#" tail acc currentType tables paramsIn paramsOut
1618else instance (FlushWhereWord acc currentType tables paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' tables paramsOut' paramsOut) => ParseWhereGo "#" tail acc currentType tables paramsIn paramsOut
1619+else instance (FlushWhereWord acc currentType tables paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' tables paramsOut' paramsOut) => ParseWhereGo "," tail acc currentType tables paramsIn paramsOut
1286
1620
1287-- End of string: flush final word
1621-- End of string: flush final word
1288else instance
1622else instance
@@ -1386,8 +1720,12 @@ else instance FlushWhereWordU word currentType tables paramsIn currentTypeOut pa
1386else instance FlushWhereWordU word currentType tables paramsIn currentTypeOut paramsOut => FlushWhereWordByHead "u" word currentType tables paramsIn currentTypeOut paramsOut
1720else instance FlushWhereWordU word currentType tables paramsIn currentTypeOut paramsOut => FlushWhereWordByHead "u" word currentType tables paramsIn currentTypeOut paramsOut
1387else instance FlushWhereWordV word currentType tables paramsIn currentTypeOut paramsOut => FlushWhereWordByHead "V" word currentType tables paramsIn currentTypeOut paramsOut
1721else instance FlushWhereWordV word currentType tables paramsIn currentTypeOut paramsOut => FlushWhereWordByHead "V" word currentType tables paramsIn currentTypeOut paramsOut
1388else instance FlushWhereWordV word currentType tables paramsIn currentTypeOut paramsOut => FlushWhereWordByHead "v" word currentType tables paramsIn currentTypeOut paramsOut
1722else instance FlushWhereWordV word currentType tables paramsIn currentTypeOut paramsOut => FlushWhereWordByHead "v" word currentType tables paramsIn currentTypeOut paramsOut
1723+else instance FlushWhereWordP word currentType tables paramsIn currentTypeOut paramsOut => FlushWhereWordByHead "P" word currentType tables paramsIn currentTypeOut paramsOut
1724+else instance FlushWhereWordP word currentType tables paramsIn currentTypeOut paramsOut => FlushWhereWordByHead "p" word currentType tables paramsIn currentTypeOut paramsOut
1725+else instance FlushWhereWordR word currentType tables paramsIn currentTypeOut paramsOut => FlushWhereWordByHead "R" word currentType tables paramsIn currentTypeOut paramsOut
1726+else instance FlushWhereWordR word currentType tables paramsIn currentTypeOut paramsOut => FlushWhereWordByHead "r" word currentType tables paramsIn currentTypeOut paramsOut
1389
1727
1390−-- Catch-all: column reference (letters without keywords like g, h, p, q, r, w, x, y, z)
1728+-- Catch-all: column reference (letters without keywords like g, h, q, w, x, y, z)
1391else instance
1729else instance
1392 ( ResolveColumn word tables entry
1730 ( ResolveColumn word tables entry
1393 , ExtractType entry typ
1731 , ExtractType entry typ
@@ -1400,7 +1738,9 @@ else instance
1400class FlushWhereWordA :: Symbol -> Type -> Row (Row Type) -> RL.RowList Type -> Type -> RL.RowList Type -> Constraint
1738class FlushWhereWordA :: Symbol -> Type -> Row (Row Type) -> RL.RowList Type -> Type -> RL.RowList Type -> Constraint
1401class FlushWhereWordA word currentType tables paramsIn currentTypeOut paramsOut | word currentType tables paramsIn -> currentTypeOut paramsOut
1739class FlushWhereWordA word currentType tables paramsIn currentTypeOut paramsOut | word currentType tables paramsIn -> currentTypeOut paramsOut
1402
1740
1741+instance FlushWhereWordA "ABS" currentType tables paramsIn currentType paramsIn
1742+else instance FlushWhereWordA "abs" currentType tables paramsIn currentType paramsIn
1403−instance FlushWhereWordA "ANY" currentType tables paramsIn (Array currentType) paramsIn
1743+else instance FlushWhereWordA "ANY" currentType tables paramsIn (Array currentType) paramsIn
1404else instance FlushWhereWordA "any" currentType tables paramsIn (Array currentType) paramsIn
1744else instance FlushWhereWordA "any" currentType tables paramsIn (Array currentType) paramsIn
1405else instance FlushWhereWordA "ALL" currentType tables paramsIn (Array currentType) paramsIn
1745else instance FlushWhereWordA "ALL" currentType tables paramsIn (Array currentType) paramsIn
1406else instance FlushWhereWordA "all" currentType tables paramsIn (Array currentType) paramsIn
1746else instance FlushWhereWordA "all" currentType tables paramsIn (Array currentType) paramsIn
@@ -1436,8 +1776,18 @@ class FlushWhereWordC word currentType tables paramsIn currentTypeOut paramsOut
1436
1776
1437instance FlushWhereWordC "CAST" currentType tables paramsIn currentType paramsIn
1777instance FlushWhereWordC "CAST" currentType tables paramsIn currentType paramsIn
1438else instance FlushWhereWordC "cast" currentType tables paramsIn currentType paramsIn
1778else instance FlushWhereWordC "cast" currentType tables paramsIn currentType paramsIn
1779+else instance FlushWhereWordC "CEIL" currentType tables paramsIn currentType paramsIn
1780+else instance FlushWhereWordC "ceil" currentType tables paramsIn currentType paramsIn
1781+else instance FlushWhereWordC "COALESCE" currentType tables paramsIn currentType paramsIn
1782+else instance FlushWhereWordC "coalesce" currentType tables paramsIn currentType paramsIn
1783+else instance FlushWhereWordC "CONCAT" currentType tables paramsIn currentType paramsIn
1784+else instance FlushWhereWordC "concat" currentType tables paramsIn currentType paramsIn
1439else instance FlushWhereWordC "COUNT" currentType tables paramsIn Int paramsIn
1785else instance FlushWhereWordC "COUNT" currentType tables paramsIn Int paramsIn
1440else instance FlushWhereWordC "count" currentType tables paramsIn Int paramsIn
1786else instance FlushWhereWordC "count" currentType tables paramsIn Int paramsIn
1787+else instance FlushWhereWordC "CURRENT_DATE" currentType tables paramsIn currentType paramsIn
1788+else instance FlushWhereWordC "current_date" currentType tables paramsIn currentType paramsIn
1789+else instance FlushWhereWordC "CURRENT_TIMESTAMP" currentType tables paramsIn currentType paramsIn
1790+else instance FlushWhereWordC "current_timestamp" currentType tables paramsIn currentType paramsIn
1441else instance
1791else instance
1442 ( ResolveColumn word tables entry
1792 ( ResolveColumn word tables entry
1443 , ExtractType entry typ
1793 , ExtractType entry typ
@@ -1448,7 +1798,8 @@ else instance
1448class FlushWhereWordD :: Symbol -> Type -> Row (Row Type) -> RL.RowList Type -> Type -> RL.RowList Type -> Constraint
1798class FlushWhereWordD :: Symbol -> Type -> Row (Row Type) -> RL.RowList Type -> Type -> RL.RowList Type -> Constraint
1449class FlushWhereWordD word currentType tables paramsIn currentTypeOut paramsOut | word currentType tables paramsIn -> currentTypeOut paramsOut
1799class FlushWhereWordD word currentType tables paramsIn currentTypeOut paramsOut | word currentType tables paramsIn -> currentTypeOut paramsOut
1450
1800
1801+instance FlushWhereWordD "DATE" currentType tables paramsIn currentType paramsIn
1451−instance FlushWhereWordD "date" currentType tables paramsIn currentType paramsIn
1802+else instance FlushWhereWordD "date" currentType tables paramsIn currentType paramsIn
1452else instance
1803else instance
1453 ( ResolveColumn word tables entry
1804 ( ResolveColumn word tables entry
1454 , ExtractType entry typ
1805 , ExtractType entry typ
@@ -1473,6 +1824,8 @@ class FlushWhereWordF word currentType tables paramsIn currentTypeOut paramsOut
1473
1824
1474instance FlushWhereWordF "FALSE" currentType tables paramsIn currentType paramsIn
1825instance FlushWhereWordF "FALSE" currentType tables paramsIn currentType paramsIn
1475else instance FlushWhereWordF "false" currentType tables paramsIn currentType paramsIn
1826else instance FlushWhereWordF "false" currentType tables paramsIn currentType paramsIn
1827+else instance FlushWhereWordF "FLOOR" currentType tables paramsIn currentType paramsIn
1828+else instance FlushWhereWordF "floor" currentType tables paramsIn currentType paramsIn
1476else instance
1829else instance
1477 ( ResolveColumn word tables entry
1830 ( ResolveColumn word tables entry
1478 , ExtractType entry typ
1831 , ExtractType entry typ
@@ -1511,8 +1864,14 @@ else instance
1511class FlushWhereWordL :: Symbol -> Type -> Row (Row Type) -> RL.RowList Type -> Type -> RL.RowList Type -> Constraint
1864class FlushWhereWordL :: Symbol -> Type -> Row (Row Type) -> RL.RowList Type -> Type -> RL.RowList Type -> Constraint
1512class FlushWhereWordL word currentType tables paramsIn currentTypeOut paramsOut | word currentType tables paramsIn -> currentTypeOut paramsOut
1865class FlushWhereWordL word currentType tables paramsIn currentTypeOut paramsOut | word currentType tables paramsIn -> currentTypeOut paramsOut
1513
1866
1867+instance FlushWhereWordL "LEAST" currentType tables paramsIn currentType paramsIn
1868+else instance FlushWhereWordL "least" currentType tables paramsIn currentType paramsIn
1869+else instance FlushWhereWordL "LENGTH" currentType tables paramsIn Int paramsIn
1870+else instance FlushWhereWordL "length" currentType tables paramsIn Int paramsIn
1514−instance FlushWhereWordL "LIKE" currentType tables paramsIn currentType paramsIn
1871+else instance FlushWhereWordL "LIKE" currentType tables paramsIn currentType paramsIn
1515else instance FlushWhereWordL "like" currentType tables paramsIn currentType paramsIn
1872else instance FlushWhereWordL "like" currentType tables paramsIn currentType paramsIn
1873+else instance FlushWhereWordL "LOWER" currentType tables paramsIn String paramsIn
1874+else instance FlushWhereWordL "lower" currentType tables paramsIn String paramsIn
1516else instance
1875else instance
1517 ( ResolveColumn word tables entry
1876 ( ResolveColumn word tables entry
1518 , ExtractType entry typ
1877 , ExtractType entry typ
@@ -1539,8 +1898,12 @@ class FlushWhereWordN word currentType tables paramsIn currentTypeOut paramsOut
1539
1898
1540instance FlushWhereWordN "NOT" currentType tables paramsIn currentType paramsIn -- unreachable (caught by FlushWhereWord directly) but included for self-containedness
1899instance FlushWhereWordN "NOT" currentType tables paramsIn currentType paramsIn -- unreachable (caught by FlushWhereWord directly) but included for self-containedness
1541else instance FlushWhereWordN "not" currentType tables paramsIn currentType paramsIn
1900else instance FlushWhereWordN "not" currentType tables paramsIn currentType paramsIn
1901+else instance FlushWhereWordN "NOW" currentType tables paramsIn currentType paramsIn
1902+else instance FlushWhereWordN "now" currentType tables paramsIn currentType paramsIn
1542else instance FlushWhereWordN "NULL" currentType tables paramsIn currentType paramsIn
1903else instance FlushWhereWordN "NULL" currentType tables paramsIn currentType paramsIn
1543else instance FlushWhereWordN "null" currentType tables paramsIn currentType paramsIn
1904else instance FlushWhereWordN "null" currentType tables paramsIn currentType paramsIn
1905+else instance FlushWhereWordN "NULLIF" currentType tables paramsIn currentType paramsIn
1906+else instance FlushWhereWordN "nullif" currentType tables paramsIn currentType paramsIn
1544else instance
1907else instance
1545 ( ResolveColumn word tables entry
1908 ( ResolveColumn word tables entry
1546 , ExtractType entry typ
1909 , ExtractType entry typ
@@ -1551,7 +1914,9 @@ else instance
1551class FlushWhereWordS :: Symbol -> Type -> Row (Row Type) -> RL.RowList Type -> Type -> RL.RowList Type -> Constraint
1914class FlushWhereWordS :: Symbol -> Type -> Row (Row Type) -> RL.RowList Type -> Type -> RL.RowList Type -> Constraint
1552class FlushWhereWordS word currentType tables paramsIn currentTypeOut paramsOut | word currentType tables paramsIn -> currentTypeOut paramsOut
1915class FlushWhereWordS word currentType tables paramsIn currentTypeOut paramsOut | word currentType tables paramsIn -> currentTypeOut paramsOut
1553
1916
1917+instance FlushWhereWordS "SMALLINT" currentType tables paramsIn currentType paramsIn
1918+else instance FlushWhereWordS "smallint" currentType tables paramsIn currentType paramsIn
1554−instance FlushWhereWordS "SUM" currentType tables paramsIn currentType paramsIn
1919+else instance FlushWhereWordS "SUM" currentType tables paramsIn currentType paramsIn
1555else instance FlushWhereWordS "sum" currentType tables paramsIn currentType paramsIn
1920else instance FlushWhereWordS "sum" currentType tables paramsIn currentType paramsIn
1556else instance FlushWhereWordS "STRING_AGG" currentType tables paramsIn String paramsIn
1921else instance FlushWhereWordS "STRING_AGG" currentType tables paramsIn String paramsIn
1557else instance FlushWhereWordS "string_agg" currentType tables paramsIn String paramsIn
1922else instance FlushWhereWordS "string_agg" currentType tables paramsIn String paramsIn
@@ -1565,11 +1930,23 @@ else instance
1565class FlushWhereWordT :: Symbol -> Type -> Row (Row Type) -> RL.RowList Type -> Type -> RL.RowList Type -> Constraint
1930class FlushWhereWordT :: Symbol -> Type -> Row (Row Type) -> RL.RowList Type -> Type -> RL.RowList Type -> Constraint
1566class FlushWhereWordT word currentType tables paramsIn currentTypeOut paramsOut | word currentType tables paramsIn -> currentTypeOut paramsOut
1931class FlushWhereWordT word currentType tables paramsIn currentTypeOut paramsOut | word currentType tables paramsIn -> currentTypeOut paramsOut
1567
1932
1933+instance FlushWhereWordT "TRIM" currentType tables paramsIn String paramsIn
1934+else instance FlushWhereWordT "trim" currentType tables paramsIn String paramsIn
1568−instance FlushWhereWordT "TRUE" currentType tables paramsIn currentType paramsIn
1935+else instance FlushWhereWordT "TRUE" currentType tables paramsIn currentType paramsIn
1569else instance FlushWhereWordT "true" currentType tables paramsIn currentType paramsIn
1936else instance FlushWhereWordT "true" currentType tables paramsIn currentType paramsIn
1570else instance FlushWhereWordT "text" currentType tables paramsIn currentType paramsIn
1937else instance FlushWhereWordT "text" currentType tables paramsIn currentType paramsIn
1571else instance FlushWhereWordT "timestamptz" currentType tables paramsIn currentType paramsIn
1938else instance FlushWhereWordT "timestamptz" currentType tables paramsIn currentType paramsIn
1572else instance FlushWhereWordT "timestamp" currentType tables paramsIn currentType paramsIn
1939else instance FlushWhereWordT "timestamp" currentType tables paramsIn currentType paramsIn
1940+else instance FlushWhereWordT "TIME" currentType tables paramsIn currentType paramsIn
1941+else instance FlushWhereWordT "time" currentType tables paramsIn currentType paramsIn
1942+else instance FlushWhereWordT "tsvector" currentType tables paramsIn currentType paramsIn
1943+else instance FlushWhereWordT "TSVECTOR" currentType tables paramsIn currentType paramsIn
1944+else instance FlushWhereWordT "tsquery" currentType tables paramsIn currentType paramsIn
1945+else instance FlushWhereWordT "TSQUERY" currentType tables paramsIn currentType paramsIn
1946+else instance FlushWhereWordT "to_tsvector" currentType tables paramsIn String paramsIn
1947+else instance FlushWhereWordT "TO_TSVECTOR" currentType tables paramsIn String paramsIn
1948+else instance FlushWhereWordT "to_tsquery" currentType tables paramsIn String paramsIn
1949+else instance FlushWhereWordT "TO_TSQUERY" currentType tables paramsIn String paramsIn
1573else instance
1950else instance
1574 ( ResolveColumn word tables entry
1951 ( ResolveColumn word tables entry
1575 , ExtractType entry typ
1952 , ExtractType entry typ
@@ -1580,7 +1957,9 @@ else instance
1580class FlushWhereWordU :: Symbol -> Type -> Row (Row Type) -> RL.RowList Type -> Type -> RL.RowList Type -> Constraint
1957class FlushWhereWordU :: Symbol -> Type -> Row (Row Type) -> RL.RowList Type -> Type -> RL.RowList Type -> Constraint
1581class FlushWhereWordU word currentType tables paramsIn currentTypeOut paramsOut | word currentType tables paramsIn -> currentTypeOut paramsOut
1958class FlushWhereWordU word currentType tables paramsIn currentTypeOut paramsOut | word currentType tables paramsIn -> currentTypeOut paramsOut
1582
1959
1960+instance FlushWhereWordU "UPPER" currentType tables paramsIn String paramsIn
1961+else instance FlushWhereWordU "upper" currentType tables paramsIn String paramsIn
1583−instance FlushWhereWordU "uuid" currentType tables paramsIn currentType paramsIn
1962+else instance FlushWhereWordU "uuid" currentType tables paramsIn currentType paramsIn
1584else instance
1963else instance
1585 ( ResolveColumn word tables entry
1964 ( ResolveColumn word tables entry
1586 , ExtractType entry typ
1965 , ExtractType entry typ
@@ -1599,6 +1978,32 @@ else instance
1599 ) =>
1978 ) =>
1600 FlushWhereWordV word currentType tables paramsIn unwrapped paramsIn
1979 FlushWhereWordV word currentType tables paramsIn unwrapped paramsIn
1601
1980
1981+class FlushWhereWordP :: Symbol -> Type -> Row (Row Type) -> RL.RowList Type -> Type -> RL.RowList Type -> Constraint
1982+class FlushWhereWordP word currentType tables paramsIn currentTypeOut paramsOut | word currentType tables paramsIn -> currentTypeOut paramsOut
1983+
1984+instance FlushWhereWordP "point" currentType tables paramsIn currentType paramsIn
1985+else instance FlushWhereWordP "POINT" currentType tables paramsIn currentType paramsIn
1986+else instance FlushWhereWordP "plainto_tsquery" currentType tables paramsIn currentType paramsIn
1987+else instance FlushWhereWordP "PLAINTO_TSQUERY" currentType tables paramsIn currentType paramsIn
1988+else instance
1989+ ( ResolveColumn word tables entry
1990+ , ExtractType entry typ
1991+ , UnwrapMaybe typ unwrapped
1992+ ) =>
1993+ FlushWhereWordP word currentType tables paramsIn unwrapped paramsIn
1994+
1995+class FlushWhereWordR :: Symbol -> Type -> Row (Row Type) -> RL.RowList Type -> Type -> RL.RowList Type -> Constraint
1996+class FlushWhereWordR word currentType tables paramsIn currentTypeOut paramsOut | word currentType tables paramsIn -> currentTypeOut paramsOut
1997+
1998+instance FlushWhereWordR "real" currentType tables paramsIn currentType paramsIn
1999+else instance FlushWhereWordR "REAL" currentType tables paramsIn currentType paramsIn
2000+else instance
2001+ ( ResolveColumn word tables entry
2002+ , ExtractType entry typ
2003+ , UnwrapMaybe typ unwrapped
2004+ ) =>
2005+ FlushWhereWordR word currentType tables paramsIn unwrapped paramsIn
2006+
1602-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
2007-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
1603-- ValidateColumnList: comma-separated column references
2008-- ValidateColumnList: comma-separated column references
1604-- Used by GROUP BY, DISTINCT ON, ON CONFLICT target
2009-- Used by GROUP BY, DISTINCT ON, ON CONFLICT target
@@ -1671,11 +2076,16 @@ else instance
1671class ValidateOrderByGo :: Symbol -> Symbol -> Symbol -> Row (Row Type) -> Constraint
2076class ValidateOrderByGo :: Symbol -> Symbol -> Symbol -> Row (Row Type) -> Constraint
1672class ValidateOrderByGo head tail acc tables
2077class ValidateOrderByGo head tail acc tables
1673
2078
1674−-- Comma: flush column, continue
2079+-- Leading/double comma: no column before comma
1675instance
2080instance
2081+ Fail (Text "Unexpected comma in ORDER BY clause (missing column name)") =>
2082+ ValidateOrderByGo "," tail "" tables
2083+
2084+-- Comma: flush column, continue (non-empty acc)
2085+else instance
1676 ( FlushOrderByWord acc tables
2086 ( FlushOrderByWord acc tables
1677 , SkipSpaces tail rest
2087 , SkipSpaces tail rest
1678− , ValidateOrderBy rest tables
2088+ , ValidateOrderByContinueNonEmpty rest tables
1679 ) =>
2089 ) =>
1680 ValidateOrderByGo "," tail acc tables
2090 ValidateOrderByGo "," tail acc tables
1681
2091
@@ -1689,7 +2099,7 @@ else instance
1689-- End of string: flush final column
2099-- End of string: flush final column
1690else instance
2100else instance
1691 ( Symbol.Append acc h acc'
2101 ( Symbol.Append acc h acc'
1692− , FlushOrderByWord acc' tables
2102+ , FlushOrderByFinalWord acc' tables
1693 ) =>
2103 ) =>
1694 ValidateOrderByGo h "" acc tables
2104 ValidateOrderByGo h "" acc tables
1695
2105
@@ -1701,6 +2111,31 @@ else instance
1701 ) =>
2111 ) =>
1702 ValidateOrderByGo h tail acc tables
2112 ValidateOrderByGo h tail acc tables
1703
2113
2114+-- After comma: reject empty (trailing comma)
2115+class ValidateOrderByContinueNonEmpty :: Symbol -> Row (Row Type) -> Constraint
2116+class ValidateOrderByContinueNonEmpty sym tables
2117+
2118+instance Fail (Text "Trailing comma in ORDER BY clause") => ValidateOrderByContinueNonEmpty "" tables
2119+else instance
2120+ ( Symbol.Cons h t sym
2121+ , ValidateOrderByGo h t "" tables
2122+ ) =>
2123+ ValidateOrderByContinueNonEmpty sym tables
2124+
2125+-- End of string: reject bare modifiers (ASC/DESC without column)
2126+class FlushOrderByFinalWord :: Symbol -> Row (Row Type) -> Constraint
2127+class FlushOrderByFinalWord word tables
2128+
2129+instance Fail (Text "ORDER BY requires at least one column") => FlushOrderByFinalWord "" tables
2130+else instance Fail (Text "ORDER BY requires a column name before ASC/DESC") => FlushOrderByFinalWord "ASC" tables
2131+else instance Fail (Text "ORDER BY requires a column name before ASC/DESC") => FlushOrderByFinalWord "asc" tables
2132+else instance Fail (Text "ORDER BY requires a column name before ASC/DESC") => FlushOrderByFinalWord "DESC" tables
2133+else instance Fail (Text "ORDER BY requires a column name before ASC/DESC") => FlushOrderByFinalWord "desc" tables
2134+else instance Fail (Text "ORDER BY requires a column name before ASC/DESC") => FlushOrderByFinalWord "NULLS" tables
2135+else instance Fail (Text "ORDER BY requires a column name before ASC/DESC") => FlushOrderByFinalWord "FIRST" tables
2136+else instance Fail (Text "ORDER BY requires a column name before ASC/DESC") => FlushOrderByFinalWord "LAST" tables
2137+else instance ResolveColumn word tables typ => FlushOrderByFinalWord word tables
2138+
1704class FlushOrderByWord :: Symbol -> Row (Row Type) -> Constraint
2139class FlushOrderByWord :: Symbol -> Row (Row Type) -> Constraint
1705class FlushOrderByWord word tables
2140class FlushOrderByWord word tables
1706
2141
@@ -2130,6 +2565,14 @@ else instance (FlushJoinWord acc tables, ValidateJoinCondition tail tables) => V
2130else instance (FlushJoinWord acc tables, ValidateJoinCondition tail tables) => ValidateJoinCondGo "(" tail acc tables
2565else instance (FlushJoinWord acc tables, ValidateJoinCondition tail tables) => ValidateJoinCondGo "(" tail acc tables
2131else instance (FlushJoinWord acc tables, ValidateJoinCondition tail tables) => ValidateJoinCondGo ")" tail acc tables
2566else instance (FlushJoinWord acc tables, ValidateJoinCondition tail tables) => ValidateJoinCondGo ")" tail acc tables
2132
2567
2568+-- String literal: skip content between quotes
2569+else instance
2570+ ( FlushJoinWord acc tables
2571+ , SkipStringLiteral tail rest
2572+ , ValidateJoinCondition rest tables
2573+ ) =>
2574+ ValidateJoinCondGo "'" tail acc tables
2575+
2133-- End of string: flush final word
2576-- End of string: flush final word
2134else instance
2577else instance
2135 ( Symbol.Append acc h acc'
2578 ( Symbol.Append acc h acc'
@@ -2214,13 +2657,85 @@ else instance
2214 , SkipSpaces rest1 rest2
2657 , SkipSpaces rest1 rest2
2215 , ExpectChar rest2 "=" rest3
2658 , ExpectChar rest2 "=" rest3
2216 , SkipSpaces rest3 rest4
2659 , SkipSpaces rest3 rest4
2217− , ExtractWord rest4 excRef rest5
2660+ , SkipExpression rest4 rest5
2218− , ValidateExcludedRef excRef colName
2219− , SkipSpaces rest5 rest6
2220− , ParseAssignmentsContinue rest6 cols
2661+ , ParseAssignmentsContinue rest5 cols
2221 ) =>
2662 ) =>
2222 ParseAssignments sym cols
2663 ParseAssignments sym cols
2223
2664
2665+-- | Skip a SQL expression on the RHS of an assignment.
2666+-- | Handles balanced parentheses so that e.g. now() and
2667+-- | COALESCE(EXCLUDED.value, '') are consumed as a single expression.
2668+-- | Stops at an unparenthesised comma or end-of-string.
2669+class SkipExpression :: Symbol -> Symbol -> Constraint
2670+class SkipExpression sym rest | sym -> rest
2671+
2672+instance SkipExpression "" ""
2673+else instance
2674+ ( Symbol.Cons h t sym
2675+ , SkipExpressionGo h t rest
2676+ ) =>
2677+ SkipExpression sym rest
2678+
2679+class SkipExpressionGo :: Symbol -> Symbol -> Symbol -> Constraint
2680+class SkipExpressionGo head tail rest | head tail -> rest
2681+
2682+-- Comma at depth 0 → stop, keep comma in rest
2683+instance Symbol.Cons "," tail rest => SkipExpressionGo "," tail rest
2684+-- Open paren → enter nested expression
2685+else instance
2686+ ( SkipNested tail rest1
2687+ , SkipExpression rest1 rest
2688+ ) =>
2689+ SkipExpressionGo "(" tail rest
2690+-- Space → skip and continue (expressions can have spaces, e.g. "EXCLUDED.col")
2691+else instance (SkipSpaces tail rest1, SkipExpressionAfterSpace rest1 rest) => SkipExpressionGo " " tail rest
2692+-- End of string after this char
2693+else instance SkipExpressionGo h "" ""
2694+-- Regular char → continue
2695+else instance (Symbol.Cons h2 t2 tail, SkipExpressionGo h2 t2 rest) => SkipExpressionGo h tail rest
2696+
2697+-- | After a space in an expression, check if we've hit a comma or a new assignment (word = ...).
2698+-- | If the next word is a column name followed by '=', this is a new assignment, so stop.
2699+-- | Otherwise, continue the expression.
2700+class SkipExpressionAfterSpace :: Symbol -> Symbol -> Constraint
2701+class SkipExpressionAfterSpace sym rest | sym -> rest
2702+
2703+instance SkipExpressionAfterSpace "" ""
2704+else instance
2705+ ( Symbol.Cons h t sym
2706+ , SkipExpressionAfterSpaceGo h t sym rest
2707+ ) =>
2708+ SkipExpressionAfterSpace sym rest
2709+
2710+class SkipExpressionAfterSpaceGo :: Symbol -> Symbol -> Symbol -> Symbol -> Constraint
2711+class SkipExpressionAfterSpaceGo head tail sym rest | head tail sym -> rest
2712+
2713+-- Comma → stop
2714+instance Symbol.Cons "," tail rest => SkipExpressionAfterSpaceGo "," tail sym rest
2715+-- Otherwise continue the expression
2716+else instance (SkipExpressionGo h tail rest) => SkipExpressionAfterSpaceGo h tail sym rest
2717+
2718+-- | Skip a parenthesised group (after the opening paren has been consumed).
2719+-- | Handles nesting.
2720+class SkipNested :: Symbol -> Symbol -> Constraint
2721+class SkipNested sym rest | sym -> rest
2722+
2723+instance
2724+ ( Symbol.Cons h t sym
2725+ , SkipNestedGo h t rest
2726+ ) =>
2727+ SkipNested sym rest
2728+
2729+class SkipNestedGo :: Symbol -> Symbol -> Symbol -> Constraint
2730+class SkipNestedGo head tail rest | head tail -> rest
2731+
2732+-- Close paren → done
2733+instance SkipNestedGo ")" tail tail
2734+-- Open paren → recurse
2735+else instance (SkipNested tail rest1, SkipNested rest1 rest) => SkipNestedGo "(" tail rest
2736+-- Any other char → continue
2737+else instance (SkipNested tail rest) => SkipNestedGo h tail rest
2738+
2224class ParseAssignmentsContinue :: Symbol -> Row Type -> Constraint
2739class ParseAssignmentsContinue :: Symbol -> Row Type -> Constraint
2225class ParseAssignmentsContinue sym cols
2740class ParseAssignmentsContinue sym cols
2226
2741
@@ -2283,6 +2798,7 @@ class IsAutoGeneratedTC constraints result | constraints -> result
2283
2798
2284instance IsAutoGeneratedTC (AutoIncrement a) True
2799instance IsAutoGeneratedTC (AutoIncrement a) True
2285else instance IsAutoGeneratedTC (Default s a) True
2800else instance IsAutoGeneratedTC (Default s a) True
2801+else instance IsAutoGeneratedTC (DefaultExpr expression a) True
2286else instance IsAutoGeneratedTC a result => IsAutoGeneratedTC (PrimaryKey a) result
2802else instance IsAutoGeneratedTC a result => IsAutoGeneratedTC (PrimaryKey a) result
2287else instance IsAutoGeneratedTC a result => IsAutoGeneratedTC (Unique a) result
2803else instance IsAutoGeneratedTC a result => IsAutoGeneratedTC (Unique a) result
2288else instance IsAutoGeneratedTC a result => IsAutoGeneratedTC (ForeignKey t r c a) result
2804else instance IsAutoGeneratedTC a result => IsAutoGeneratedTC (ForeignKey t r c a) result
@@ -2338,11 +2854,19 @@ class FieldToPGValue a where
2338 fieldToPGValue :: a -> PG.PGValue
2854 fieldToPGValue :: a -> PG.PGValue
2339
2855
2340instance FieldToPGValue a => FieldToPGValue (Maybe a) where
2856instance FieldToPGValue a => FieldToPGValue (Maybe a) where
2341− fieldToPGValue = toNullable >>> unsafeCoerce
2857+ fieldToPGValue = case _ of
2858+ Nothing -> unsafeCoerce (toNullable Nothing)
2859+ Just value -> fieldToPGValue value
2342else instance FieldToPGValue DateTime where
2860else instance FieldToPGValue DateTime where
2343 fieldToPGValue = JSDate.fromDateTime >>> unsafeCoerce
2861 fieldToPGValue = JSDate.fromDateTime >>> unsafeCoerce
2344−else instance FieldToPGValue a where
2862+else instance FieldToPGValue TimestampTZ where
2863+ fieldToPGValue (TimestampTZ dt) = JSDate.fromDateTime dt # unsafeCoerce
2864+else instance FieldToPGValue PGDate where
2865+ fieldToPGValue = writeImpl >>> unsafeCoerce
2866+else instance FieldToPGValue PGUUID where
2345 fieldToPGValue = unsafeCoerce
2867 fieldToPGValue = unsafeCoerce
2868+else instance WriteForeign a => FieldToPGValue a where
2869+ fieldToPGValue = writeImpl >>> unsafeCoerce
2346
2870
2347class RecordValuesRL :: RL.RowList Type -> Row Type -> Constraint
2871class RecordValuesRL :: RL.RowList Type -> Row Type -> Constraint
2348class RecordValuesRL rl row where
2872class RecordValuesRL rl row where
@@ -2410,6 +2934,20 @@ else instance HasAnyDMLRL (RL.Cons "delete" Unit rest)
2410else instance HasAnyDMLRL rest => HasAnyDMLRL (RL.Cons label typ rest)
2934else instance HasAnyDMLRL rest => HasAnyDMLRL (RL.Cons label typ rest)
2411else instance Fail (Text "WHERE requires a preceding SELECT, UPDATE (set), or DELETE") => HasAnyDMLRL RL.Nil
2935else instance Fail (Text "WHERE requires a preceding SELECT, UPDATE (set), or DELETE") => HasAnyDMLRL RL.Nil
2412
2936
2937+class HasMutation :: Row Type -> Constraint
2938+class HasMutation stage
2939+
2940+instance (RL.RowToList stage rl, HasMutationRL rl) => HasMutation stage
2941+
2942+class HasMutationRL :: RL.RowList Type -> Constraint
2943+class HasMutationRL rl
2944+
2945+instance HasMutationRL (RL.Cons "insert" Unit rest)
2946+else instance HasMutationRL (RL.Cons "set" Unit rest)
2947+else instance HasMutationRL (RL.Cons "delete" Unit rest)
2948+else instance HasMutationRL rest => HasMutationRL (RL.Cons label typ rest)
2949+else instance Fail (Text "RETURNING requires a preceding INSERT, UPDATE (set), or DELETE") => HasMutationRL RL.Nil
2950+
2413toSQL :: forall tables result params stage. Q tables result params stage -> String
2951toSQL :: forall tables result params stage. Q tables result params stage -> String
2414toSQL (Q q) = q.sql
2952toSQL (Q q) = q.sql
2415
2953
@@ -2419,6 +2957,12 @@ from _ = Q { sql: reflectSymbol (Proxy :: Proxy name), values: [] }
2419fromAs :: forall @alias name cols tables. IsSymbol name => IsSymbol alias => Row.Cons alias cols () tables => Proxy (Table name cols) -> Q tables () () ()
2957fromAs :: forall @alias name cols tables. IsSymbol name => IsSymbol alias => Row.Cons alias cols () tables => Proxy (Table name cols) -> Q tables () () ()
2420fromAs _ = Q { sql: reflectSymbol (Proxy :: Proxy name) <> " " <> reflectSymbol (Proxy :: Proxy alias), values: [] }
2958fromAs _ = Q { sql: reflectSymbol (Proxy :: Proxy name) <> " " <> reflectSymbol (Proxy :: Proxy alias), values: [] }
2421
2959
2960+into :: forall name cols tables. IsSymbol name => Row.Cons name cols () tables => Proxy (Table name cols) -> Q tables () () (into :: Unit)
2961+into _ = Q { sql: reflectSymbol (Proxy :: Proxy name), values: [] }
2962+
2963+update :: forall name cols tables. IsSymbol name => Row.Cons name cols () tables => Proxy (Table name cols) -> Q tables () () (update :: Unit)
2964+update _ = Q { sql: reflectSymbol (Proxy :: Proxy name), values: [] }
2965+
2422selectAll
2966selectAll
2423 :: forall tables name cols result r p stage stage'
2967 :: forall tables name cols result r p stage stage'
2424 . SingleTable tables name cols
2968 . SingleTable tables name cols
@@ -2426,6 +2970,7 @@ selectAll
2426 => StripColumns cols result
2970 => StripColumns cols result
2427 => Row.Lacks "select" stage
2971 => Row.Lacks "select" stage
2428 => Row.Lacks "insert" stage
2972 => Row.Lacks "insert" stage
2973+ => Row.Lacks "into" stage
2429 => Row.Lacks "set" stage
2974 => Row.Lacks "set" stage
2430 => Row.Lacks "delete" stage
2975 => Row.Lacks "delete" stage
2431 => Row.Lacks "where" stage
2976 => Row.Lacks "where" stage
@@ -2443,6 +2988,7 @@ select
2443 => ParseSelect sel tables result
2988 => ParseSelect sel tables result
2444 => Row.Lacks "select" stage
2989 => Row.Lacks "select" stage
2445 => Row.Lacks "insert" stage
2990 => Row.Lacks "insert" stage
2991+ => Row.Lacks "into" stage
2446 => Row.Lacks "set" stage
2992 => Row.Lacks "set" stage
2447 => Row.Lacks "delete" stage
2993 => Row.Lacks "delete" stage
2448 => Row.Lacks "where" stage
2994 => Row.Lacks "where" stage
@@ -2460,6 +3006,7 @@ selectDistinct
2460 => ParseSelect sel tables result
3006 => ParseSelect sel tables result
2461 => Row.Lacks "select" stage
3007 => Row.Lacks "select" stage
2462 => Row.Lacks "insert" stage
3008 => Row.Lacks "insert" stage
3009+ => Row.Lacks "into" stage
2463 => Row.Lacks "set" stage
3010 => Row.Lacks "set" stage
2464 => Row.Lacks "delete" stage
3011 => Row.Lacks "delete" stage
2465 => Row.Lacks "where" stage
3012 => Row.Lacks "where" stage
@@ -2480,6 +3027,7 @@ selectDistinctOn
2480 => ParseSelect sel tables result
3027 => ParseSelect sel tables result
2481 => Row.Lacks "select" stage
3028 => Row.Lacks "select" stage
2482 => Row.Lacks "insert" stage
3029 => Row.Lacks "insert" stage
3030+ => Row.Lacks "into" stage
2483 => Row.Lacks "set" stage
3031 => Row.Lacks "set" stage
2484 => Row.Lacks "delete" stage
3032 => Row.Lacks "delete" stage
2485 => Row.Lacks "where" stage
3033 => Row.Lacks "where" stage
@@ -2570,16 +3118,66 @@ instance
2570
3118
2571instance ParseLimitOffsetParams False name params params
3119instance ParseLimitOffsetParams False name params params
2572
3120
3121+-- Validate that a Symbol is a non-negative integer (all digits, non-empty)
3122+class ValidateNumericLiteral :: Symbol -> Constraint
3123+class ValidateNumericLiteral sym
3124+
3125+instance
3126+ ( Symbol.Cons h t sym
3127+ , ValidateAllDigits h t
3128+ ) =>
3129+ ValidateNumericLiteral sym
3130+
3131+class ValidateAllDigits :: Symbol -> Symbol -> Constraint
3132+class ValidateAllDigits head tail
3133+
3134+instance ValidateAllDigits "0" ""
3135+else instance ValidateAllDigits "1" ""
3136+else instance ValidateAllDigits "2" ""
3137+else instance ValidateAllDigits "3" ""
3138+else instance ValidateAllDigits "4" ""
3139+else instance ValidateAllDigits "5" ""
3140+else instance ValidateAllDigits "6" ""
3141+else instance ValidateAllDigits "7" ""
3142+else instance ValidateAllDigits "8" ""
3143+else instance ValidateAllDigits "9" ""
3144+else instance (Symbol.Cons h2 t2 tail, ValidateAllDigits h2 t2) => ValidateAllDigits "0" tail
3145+else instance (Symbol.Cons h2 t2 tail, ValidateAllDigits h2 t2) => ValidateAllDigits "1" tail
3146+else instance (Symbol.Cons h2 t2 tail, ValidateAllDigits h2 t2) => ValidateAllDigits "2" tail
3147+else instance (Symbol.Cons h2 t2 tail, ValidateAllDigits h2 t2) => ValidateAllDigits "3" tail
3148+else instance (Symbol.Cons h2 t2 tail, ValidateAllDigits h2 t2) => ValidateAllDigits "4" tail
3149+else instance (Symbol.Cons h2 t2 tail, ValidateAllDigits h2 t2) => ValidateAllDigits "5" tail
3150+else instance (Symbol.Cons h2 t2 tail, ValidateAllDigits h2 t2) => ValidateAllDigits "6" tail
3151+else instance (Symbol.Cons h2 t2 tail, ValidateAllDigits h2 t2) => ValidateAllDigits "7" tail
3152+else instance (Symbol.Cons h2 t2 tail, ValidateAllDigits h2 t2) => ValidateAllDigits "8" tail
3153+else instance (Symbol.Cons h2 t2 tail, ValidateAllDigits h2 t2) => ValidateAllDigits "9" tail
3154+else instance
3155+ Fail (Beside (Text "LIMIT/OFFSET must be a non-negative integer or $parameter, got: ") (Quote sym)) =>
3156+ ValidateAllDigits head tail
3157+
2573class ParseLimitOffset :: Symbol -> Row Type -> Row Type -> Constraint
3158class ParseLimitOffset :: Symbol -> Row Type -> Row Type -> Constraint
2574class ParseLimitOffset sym params params' | sym params -> params'
3159class ParseLimitOffset sym params params' | sym params -> params'
2575
3160
2576instance
3161instance
2577 ( Symbol.Cons head tail sym
3162 ( Symbol.Cons head tail sym
2578 , IsLimitParam head tail isParam
3163 , IsLimitParam head tail isParam
2579− , ParseLimitOffsetParams isParam tail params params'
3164+ , ParseLimitOffsetBranch isParam sym tail params params'
2580 ) =>
3165 ) =>
2581 ParseLimitOffset sym params params'
3166 ParseLimitOffset sym params params'
2582
3167
3168+class ParseLimitOffsetBranch :: Boolean -> Symbol -> Symbol -> Row Type -> Row Type -> Constraint
3169+class ParseLimitOffsetBranch isParam sym paramName params params' | isParam sym paramName params -> params'
3170+
3171+instance
3172+ ( Row.Lacks paramName params
3173+ , Row.Cons paramName Int params params'
3174+ ) =>
3175+ ParseLimitOffsetBranch True sym paramName params params'
3176+
3177+instance
3178+ ValidateNumericLiteral sym =>
3179+ ParseLimitOffsetBranch False sym paramName params params
3180+
2583limit
3181limit
2584 :: forall @sym tables result params params' stage stage'
3182 :: forall @sym tables result params params' stage stage'
2585 . ParseLimitOffset sym params params'
3183 . ParseLimitOffset sym params params'
@@ -2634,13 +3232,17 @@ insert rec _ = Q { sql, values }
2634 tableName = reflectSymbol (Proxy :: Proxy name)
3232 tableName = reflectSymbol (Proxy :: Proxy name)
2635 colNames = columnNamesRL (Proxy :: Proxy userRowRL)
3233 colNames = columnNamesRL (Proxy :: Proxy userRowRL)
2636 placeholders = colNames # mapWithIndex \i _ -> "$" <> show (i + 1)
3234 placeholders = colNames # mapWithIndex \i _ -> "$" <> show (i + 1)
3235+ sql =
3236+ if Array.null colNames then
2637− sql = "INSERT INTO " <> tableName
3237+ "INSERT INTO " <> tableName <> " DEFAULT VALUES"
3238+ else
3239+ "INSERT INTO " <> tableName
2638− <> " ("
3240+ <> " ("
2639− <> intercalate ", " colNames
3241+ <> intercalate ", " colNames
2640− <> ")"
3242+ <> ")"
2641− <> " VALUES ("
3243+ <> " VALUES ("
2642− <> intercalate ", " placeholders
3244+ <> intercalate ", " placeholders
2643− <> ")"
3245+ <> ")"
2644 values = recordValuesRL (Proxy :: Proxy userRowRL) rec
3246 values = recordValuesRL (Proxy :: Proxy userRowRL) rec
2645
3247
2646-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
3248-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
@@ -2652,6 +3254,7 @@ returning
2652 . SingleTable tables name cols
3254 . SingleTable tables name cols
2653 => IsSymbol sel
3255 => IsSymbol sel
2654 => ParseSelect sel tables result
3256 => ParseSelect sel tables result
3257+ => HasMutation stage
2655 => Row.Lacks "returning" stage
3258 => Row.Lacks "returning" stage
2656 => Row.Lacks "select" stage
3259 => Row.Lacks "select" stage
2657 => Row.Cons "returning" Unit stage stage'
3260 => Row.Cons "returning" Unit stage stage'
@@ -2663,6 +3266,7 @@ returningAll
2663 :: forall tables name cols result p stage stage'
3266 :: forall tables name cols result p stage stage'
2664 . SingleTable tables name cols
3267 . SingleTable tables name cols
2665 => StripColumns cols result
3268 => StripColumns cols result
3269+ => HasMutation stage
2666 => Row.Lacks "returning" stage
3270 => Row.Lacks "returning" stage
2667 => Row.Lacks "select" stage
3271 => Row.Lacks "select" stage
2668 => Row.Cons "returning" Unit stage stage'
3272 => Row.Cons "returning" Unit stage stage'
@@ -2705,8 +3309,10 @@ set
2705 => ValidateSetColumnsRL setRL cols
3309 => ValidateSetColumnsRL setRL cols
2706 => SetClauseRL setRL
3310 => SetClauseRL setRL
2707 => RecordValuesRL setRL setRow
3311 => RecordValuesRL setRL setRow
3312+ => HasClause "update" stage
2708 => Row.Lacks "select" stage
3313 => Row.Lacks "select" stage
2709 => Row.Lacks "insert" stage
3314 => Row.Lacks "insert" stage
3315+ => Row.Lacks "into" stage
2710 => Row.Lacks "set" stage
3316 => Row.Lacks "set" stage
2711 => Row.Lacks "delete" stage
3317 => Row.Lacks "delete" stage
2712 => Row.Cons "set" Unit stage stage'
3318 => Row.Cons "set" Unit stage stage'
@@ -2730,6 +3336,7 @@ delete
2730 => IsSymbol name
3336 => IsSymbol name
2731 => Row.Lacks "select" stage
3337 => Row.Lacks "select" stage
2732 => Row.Lacks "insert" stage
3338 => Row.Lacks "insert" stage
3339+ => Row.Lacks "into" stage
2733 => Row.Lacks "set" stage
3340 => Row.Lacks "set" stage
2734 => Row.Lacks "delete" stage
3341 => Row.Lacks "delete" stage
2735 => Row.Cons "delete" Unit stage stage'
3342 => Row.Cons "delete" Unit stage stage'
@@ -2970,6 +3577,66 @@ exceptAll
2970 -> Q tables1 result params SetOpStage
3577 -> Q tables1 result params SetOpStage
2971exceptAll (Q q1) (Q q2) = Q { sql: "(" <> q1.sql <> ") EXCEPT ALL (" <> q2.sql <> ")", values: q1.values <> q2.values }
3578exceptAll (Q q1) (Q q2) = Q { sql: "(" <> q1.sql <> ") EXCEPT ALL (" <> q2.sql <> ")", values: q1.values <> q2.values }
2972
3579
3580+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
3581+-- CTE (WITH clause) support
3582+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
3583+
3584+newtype WithCTEs :: Row (Row Type) -> Row Type -> Type
3585+newtype WithCTEs cteTables cteParams = WithCTEs
3586+ { sql :: String, values :: Array PG.PGValue }
3587+
3588+-- Wrap a complete SELECT query as a named CTE
3589+cte
3590+ :: forall @name tables result params stage cteTables
3591+ . IsSymbol name
3592+ => HasClause "select" stage
3593+ => Row.Cons name result () cteTables
3594+ => Q tables result params stage
3595+ -> WithCTEs cteTables params
3596+cte (Q q) = WithCTEs
3597+ { sql: reflectSymbol (Proxy :: Proxy name) <> " AS (" <> q.sql <> ")"
3598+ , values: q.values
3599+ }
3600+
3601+-- Add another named CTE to an accumulator
3602+andCTE
3603+ :: forall @name tables result params stage cteTables cteParams cteTables' cteParams'
3604+ . IsSymbol name
3605+ => HasClause "select" stage
3606+ => Row.Lacks name cteTables
3607+ => Row.Cons name result cteTables cteTables'
3608+ => Row.Union cteParams params cteParams'
3609+ => Row.Nub cteParams' cteParams'
3610+ => Q tables result params stage
3611+ -> WithCTEs cteTables cteParams
3612+ -> WithCTEs cteTables' cteParams'
3613+andCTE (Q q) (WithCTEs w) = WithCTEs
3614+ { sql: w.sql <> ", " <> reflectSymbol (Proxy :: Proxy name) <> " AS (" <> q.sql <> ")"
3615+ , values: w.values <> q.values
3616+ }
3617+
3618+-- Start main query FROM a named CTE; cteTables becomes available as tables
3619+fromCTE
3620+ :: forall @name result restTables cteTables cteParams
3621+ . IsSymbol name
3622+ => Row.Cons name result restTables cteTables
3623+ => WithCTEs cteTables cteParams
3624+ -> Q cteTables () () ()
3625+fromCTE _ = Q { sql: reflectSymbol (Proxy :: Proxy name), values: [] }
3626+
3627+-- Finalize: prepend WITH clause and merge params
3628+with_
3629+ :: forall cteTables cteParams mainParams allParams result stage
3630+ . Row.Union cteParams mainParams allParams
3631+ => Row.Nub allParams allParams
3632+ => WithCTEs cteTables cteParams
3633+ -> Q cteTables result mainParams stage
3634+ -> Q cteTables result allParams stage
3635+with_ (WithCTEs w) (Q q) = Q
3636+ { sql: "WITH " <> w.sql <> " " <> q.sql
3637+ , values: w.values <> q.values
3638+ }
3639+
2973-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
3640-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
2974-- Query execution
3641-- Query execution
2975-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
3642-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
@@ -2985,28 +3652,34 @@ instance
2985 ( IsSymbol name
3652 ( IsSymbol name
2986 , Row.Cons name typ rest row
3653 , Row.Cons name typ rest row
2987 , Row.Lacks name rest
3654 , Row.Lacks name rest
3655+ , FieldToPGValue typ
2988 , ParamsToArray tail row
3656 , ParamsToArray tail row
2989 ) =>
3657 ) =>
2990 ParamsToArray (RL.Cons name typ tail) row where
3658 ParamsToArray (RL.Cons name typ tail) row where
2991 paramsToArray _ rec =
3659 paramsToArray _ rec =
2992 [ { name: reflectSymbol (Proxy :: Proxy name)
3660 [ { name: reflectSymbol (Proxy :: Proxy name)
2993− , value: unsafeToForeign (Record.get (Proxy :: Proxy name) rec)
3661+ , value: unsafeCoerce (fieldToPGValue (Record.get (Proxy :: Proxy name) rec))
2994 }
3662 }
2995 ]
3663 ]
2996 <> paramsToArray (Proxy :: Proxy tail) rec
3664 <> paramsToArray (Proxy :: Proxy tail) rec
2997
3665
2998namedParamRegex :: Regex.Regex
3666namedParamRegex :: Regex.Regex
2999−namedParamRegex = case Regex.regex "\\$[a-zA-Z_][a-zA-Z0-9_]*" Regex.global of
3667+namedParamRegex = case Regex.regex "\\$[a-zA-Z_][a-zA-Z0-9_]*(::[a-zA-Z_]+)?" Regex.global of
3000 Right r -> r
3668 Right r -> r
3001 Left _ -> unsafeCoerce unit
3669 Left _ -> unsafeCoerce unit
3002
3670
3671+stripCast :: String -> String
3672+stripCast s = case SCU.indexOf (Pattern "::") s of
3673+ Nothing -> s
3674+ Just i -> SCU.take i s
3675+
3003replaceNamedParams :: Int -> Array { name :: String, value :: Foreign } -> String -> { sql :: String, values :: Array PG.PGValue }
3676replaceNamedParams :: Int -> Array { name :: String, value :: Foreign } -> String -> { sql :: String, values :: Array PG.PGValue }
3004replaceNamedParams offset entries sql = do
3677replaceNamedParams offset entries sql = do
3005 let indexed = entries # mapWithIndex \i e -> { idx: offset + i + 1, name: e.name, value: e.value }
3678 let indexed = entries # mapWithIndex \i e -> { idx: offset + i + 1, name: e.name, value: e.value }
3006 let replacements = indexed # foldl (\m e -> Map.insert ("$" <> e.name) ("$" <> show e.idx) m) Map.empty
3679 let replacements = indexed # foldl (\m e -> Map.insert ("$" <> e.name) ("$" <> show e.idx) m) Map.empty
3007 let
3680 let
3008 sql' = Regex.replace' namedParamRegex
3681 sql' = Regex.replace' namedParamRegex
3009− ( \match _ -> case Map.lookup match replacements of
3682+ ( \match _ -> case Map.lookup (stripCast match) replacements of
3010 Nothing -> match
3683 Nothing -> match
3011 Just v -> v
3684 Just v -> v
3012 )
3685 )
@@ -3027,7 +3700,9 @@ runQuery conn params (Q q) = do
3027 let { sql, values } = replaceNamedParams (Array.length q.values) entries q.sql
3700 let { sql, values } = replaceNamedParams (Array.length q.values) entries q.sql
3028 let allValues = q.values <> values
3701 let allValues = q.values <> values
3029 result <- PG.query (PG.SQL sql) allValues conn
3702 result <- PG.query (PG.SQL sql) allValues conn
3030− pure (unsafeDecodeRows result.rows)
3703+ case decodeRows result.rows of
3704+ Left errs -> throwError (Exception.error ("Row decode failed: " <> show errs))
3705+ Right rows -> pure rows
3031
3706
3032runQueryOne
3707runQueryOne
3033 :: forall tables result params paramsRL stage
3708 :: forall tables result params paramsRL stage
@@ -3043,7 +3718,11 @@ runQueryOne conn params (Q q) = do
3043 let { sql, values } = replaceNamedParams (Array.length q.values) entries q.sql
3718 let { sql, values } = replaceNamedParams (Array.length q.values) entries q.sql
3044 let allValues = q.values <> values
3719 let allValues = q.values <> values
3045 result <- PG.queryOne (PG.SQL sql) allValues conn
3720 result <- PG.queryOne (PG.SQL sql) allValues conn
3046− pure (result <#> unsafeDecodeRow)
3721+ case result of
3722+ Nothing -> pure Nothing
3723+ Just row -> case decodeRow row of
3724+ Left errs -> throwError (Exception.error ("Row decode failed: " <> show errs))
3725+ Right a -> pure (Just a)
3047
3726
3048runExecute
3727runExecute
3049 :: forall tables params paramsRL stage
3728 :: forall tables params paramsRL stage
@@ -3075,7 +3754,9 @@ runQueryTx txn params (Q q) = do
3075 let { sql, values } = replaceNamedParams (Array.length q.values) entries q.sql
3754 let { sql, values } = replaceNamedParams (Array.length q.values) entries q.sql
3076 let allValues = q.values <> values
3755 let allValues = q.values <> values
3077 result <- PG.txQuery (PG.SQL sql) allValues txn
3756 result <- PG.txQuery (PG.SQL sql) allValues txn
3078− pure (unsafeDecodeRows result.rows)
3757+ case decodeRows result.rows of
3758+ Left errs -> throwError (Exception.error ("Row decode failed: " <> show errs))
3759+ Right rows -> pure rows
3079
3760
3080runExecuteTx
3761runExecuteTx
3081 :: forall tables params paramsRL stage
3762 :: forall tables params paramsRL stage
@@ -3091,10 +3772,9 @@ runExecuteTx txn params (Q q) = do
3091 let allValues = q.values <> values
3772 let allValues = q.values <> values
3092 PG.txExecute (PG.SQL sql) allValues txn
3773 PG.txExecute (PG.SQL sql) allValues txn
3093
3774
3094−unsafeDecodeRows :: forall a. ReadForeign a => Array Foreign -> Array a
3095−unsafeDecodeRows = map unsafeDecodeRow
3096
3775
3097−unsafeDecodeRow :: forall a. ReadForeign a => Foreign -> a
3776+decodeRows :: forall a. ReadForeign a => Array Foreign -> Either (NonEmptyList ForeignError) (Array a)
3098−unsafeDecodeRow f = case runExcept (readImpl f) of
3777+decodeRows = traverse (readImpl >>> runExcept)
3099− Left _ -> unsafeCoerce unit
3778+
3100− Right a -> a
3779+decodeRow :: forall a. ReadForeign a => Foreign -> Either (NonEmptyList ForeignError) a
3780+decodeRow = readImpl >>> runExcept
test/Behavioral.jsnew file+8
@@ -0,0 +1,8 @@
1+export const poisonRollbackImpl = (transaction) => {
2+ const reserved = transaction._reserved;
3+ const rollbackFailure = () => {
4+ throw new Error("rollback finalizer failed");
5+ };
6+ rollbackFailure.release = () => reserved.release();
7+ transaction._reserved = rollbackFailure;
8+};
test/Behavioral.pursnew file+540
@@ -0,0 +1,540 @@
1+module Test.Postgres.Behavioral where
2+
3+import Prelude
4+
5+import Control.Parallel (parTraverse)
6+import Data.Array as Array
7+import Data.Date (canonicalDate)
8+import Data.DateTime (DateTime(..))
9+import Data.Either (Either(..))
10+import Data.Enum (toEnum)
11+import Data.Maybe (Maybe(..), fromJust)
12+import Data.Identity (Identity)
13+import Data.Time (Time(..))
14+import Data.Time.Duration (Milliseconds(..))
15+import Data.UUID as UUID
16+import Effect (Effect)
17+import Effect.Aff (Aff, delay, forkAff, killFiber, throwError, try)
18+import Effect.Class (liftEffect)
19+import Effect.Exception (error, message)
20+import Effect.Ref as Ref
21+import Effect.Uncurried (EffectFn1, runEffectFn1)
22+import Foreign (unsafeToForeign)
23+import JS.BigInt (BigInt)
24+import JS.BigInt as BigInt
25+import Partial.Unsafe (unsafePartial)
26+import Prim.Boolean (True)
27+import Test.Spec (Spec, SpecT, describe, it)
28+import Test.Spec.Assertions (shouldEqual, shouldSatisfy)
29+import Type.Function (type (#))
30+import Type.Proxy (Proxy(..))
31+import Yoga.Postgres as PG
32+import Yoga.Postgres.Schema as Schema
33+import Yoga.Postgres.TypedQuery as Typed
34+import Yoga.SQL.PostgresTypes (SQLQuery, arg, combineBuilders, int, sql, str)
35+
36+isLeft :: forall a b. Either a b -> Boolean
37+isLeft (Left _) = true
38+isLeft _ = false
39+
40+poisonRollback :: PG.Transaction -> Effect Unit
41+poisonRollback = runEffectFn1 poisonRollbackImpl
42+
43+foreign import poisonRollbackImpl :: EffectFn1 PG.Transaction Unit
44+
45+testConnection :: Effect PG.Connection
46+testConnection = PG.postgres
47+ { host: PG.PostgresHost "localhost"
48+ , port: PG.PostgresPort 5434
49+ , database: PG.PostgresDatabase "test_playground"
50+ , username: PG.PostgresUsername "postgres"
51+ , password: PG.PostgresPassword "postgres"
52+ }
53+
54+type BehaviorTable = Schema.Table "behavior_values"
55+ ( id :: Int # Schema.PrimaryKey # Schema.AutoIncrement
56+ , name :: String
57+ , optional_int :: Maybe Int
58+ )
59+
60+behaviorTable :: Proxy BehaviorTable
61+behaviorTable = Proxy
62+
63+type AllDefaultTable = Schema.Table "behavior_defaults"
64+ ( active :: Boolean # Schema.Default True
65+ , id :: Int # Schema.PrimaryKey # Schema.AutoIncrement
66+ )
67+
68+allDefaultTable :: Proxy AllDefaultTable
69+allDefaultTable = Proxy
70+
71+type TxTable = Schema.Table "behavior_tx"
72+ ( id :: Int # Schema.PrimaryKey # Schema.AutoIncrement
73+ , name :: String
74+ )
75+
76+txTable :: Proxy TxTable
77+txTable = Proxy
78+
79+type TemporalParamTable = Schema.Table "behavior_temporal"
80+ ( document :: Schema.Jsonb
81+ , event_at :: Schema.TimestampTZ
82+ , event_date :: Schema.PGDate
83+ , event_time :: Schema.PGTime
84+ , label :: String
85+ , uuid :: Schema.PGUUID
86+ , optional_event_at :: Maybe Schema.TimestampTZ
87+ )
88+
89+temporalParamTable :: Proxy TemporalParamTable
90+temporalParamTable = Proxy
91+
92+typedIntQuery :: SQLQuery (n :: Int)
93+typedIntQuery = sql $ combineBuilders (combineBuilders "SELECT " (int @"n")) "::int AS n"
94+
95+typedMaybeQuery :: SQLQuery (value :: Maybe Int)
96+typedMaybeQuery = sql $ combineBuilders (combineBuilders "SELECT " (arg @(Maybe Int) @"value")) "::int AS value"
97+
98+typedBadDecodeQuery :: SQLQuery ()
99+typedBadDecodeQuery = sql $ combineBuilders "SELECT 'not-an-int' AS n" ""
100+
101+typedMutationQuery :: SQLQuery (name :: String)
102+typedMutationQuery = sql $ combineBuilders (combineBuilders "INSERT INTO behavior_values (name) VALUES (" (str @"name")) ")"
103+
104+expectedDate :: Schema.PGDate
105+expectedDate = unsafePartial do
106+ let year = fromJust (toEnum 2025)
107+ let month = fromJust (toEnum 6)
108+ let day = fromJust (toEnum 15)
109+ Schema.PGDate (canonicalDate year month day)
110+
111+expectedTime :: Schema.PGTime
112+expectedTime = unsafePartial do
113+ let hour = fromJust (toEnum 14)
114+ let minute = fromJust (toEnum 30)
115+ let second = fromJust (toEnum 45)
116+ let millisecond = fromJust (toEnum 125)
117+ Schema.PGTime (Time hour minute second millisecond)
118+
119+expectedHalfSecondTime :: Schema.PGTime
120+expectedHalfSecondTime = unsafePartial do
121+ let hour = fromJust (toEnum 14)
122+ let minute = fromJust (toEnum 30)
123+ let second = fromJust (toEnum 45)
124+ let millisecond = fromJust (toEnum 500)
125+ Schema.PGTime (Time hour minute second millisecond)
126+
127+expectedTimestamp :: Schema.TimestampTZ
128+expectedTimestamp = unsafePartial do
129+ let year = fromJust (toEnum 2025)
130+ let month = fromJust (toEnum 1)
131+ let day = fromJust (toEnum 15)
132+ let hour = fromJust (toEnum 12)
133+ let minute = fromJust (toEnum 0)
134+ let second = fromJust (toEnum 0)
135+ let millisecond = fromJust (toEnum 0)
136+ Schema.TimestampTZ (DateTime (canonicalDate year month day) (Time hour minute second millisecond))
137+
138+setupBehaviorTable :: PG.Connection -> Aff Unit
139+setupBehaviorTable conn = do
140+ _ <- PG.executeSimple (PG.SQL "DROP TABLE IF EXISTS behavior_values") conn
141+ _ <- PG.executeSimple (PG.SQL (Schema.createTableDDL @BehaviorTable)) conn
142+ pure unit
143+
144+setupTxTable :: PG.Connection -> Aff Unit
145+setupTxTable conn = do
146+ _ <- PG.executeSimple (PG.SQL "DROP TABLE IF EXISTS behavior_tx") conn
147+ _ <- PG.executeSimple (PG.SQL (Schema.createTableDDL @TxTable)) conn
148+ pure unit
149+
150+setupTemporalParamTable :: PG.Connection -> Aff Unit
151+setupTemporalParamTable conn = do
152+ _ <- PG.executeSimple (PG.SQL "DROP TABLE IF EXISTS behavior_temporal") conn
153+ _ <- PG.executeSimple (PG.SQL (Schema.createTableDDL @TemporalParamTable)) conn
154+ pure unit
155+
156+pureSpec :: Spec Unit
157+pureSpec = do
158+ describe "Postgres schema metadata and deterministic SQL" do
159+ it "renders every public scalar, array, and nullable type name" do
160+ Schema.pgTypeName (Proxy :: Proxy Int) `shouldEqual` "INTEGER"
161+ Schema.pgTypeName (Proxy :: Proxy String) `shouldEqual` "TEXT"
162+ Schema.pgTypeName (Proxy :: Proxy Boolean) `shouldEqual` "BOOLEAN"
163+ Schema.pgTypeName (Proxy :: Proxy Number) `shouldEqual` "DOUBLE PRECISION"
164+ Schema.pgTypeName (Proxy :: Proxy BigInt) `shouldEqual` "BIGINT"
165+ Schema.pgTypeName (Proxy :: Proxy Schema.PGUUID) `shouldEqual` "UUID"
166+ Schema.pgTypeName (Proxy :: Proxy Schema.PGDate) `shouldEqual` "DATE"
167+ Schema.pgTypeName (Proxy :: Proxy Schema.PGTime) `shouldEqual` "TIME"
168+ Schema.pgTypeName (Proxy :: Proxy Schema.TimestampTZ) `shouldEqual` "TIMESTAMPTZ"
169+ Schema.pgTypeName (Proxy :: Proxy Schema.Point) `shouldEqual` "POINT"
170+ Schema.pgTypeName (Proxy :: Proxy Schema.TSVector) `shouldEqual` "TSVECTOR"
171+ Schema.pgTypeName (Proxy :: Proxy Schema.TSQuery) `shouldEqual` "TSQUERY"
172+ Schema.pgTypeName (Proxy :: Proxy Schema.Jsonb) `shouldEqual` "JSONB"
173+ Schema.pgTypeName (Proxy :: Proxy (Array Int)) `shouldEqual` "INTEGER[]"
174+ Schema.pgTypeName (Proxy :: Proxy (Maybe Int)) `shouldEqual` "INTEGER"
175+
176+ it "reports nullability from Maybe only" do
177+ Schema.isNullable (Proxy :: Proxy (Maybe Int)) `shouldEqual` true
178+ Schema.isNullable (Proxy :: Proxy Int) `shouldEqual` false
179+
180+ it "renders IF NOT EXISTS and DEFAULT VALUES DDL" do
181+ Schema.createTableDDLIfNotExists @BehaviorTable
182+ `shouldEqual` "CREATE TABLE IF NOT EXISTS behavior_values (id INTEGER NOT NULL GENERATED ALWAYS AS IDENTITY PRIMARY KEY, name TEXT NOT NULL, optional_int INTEGER)"
183+ Schema.insertSQLFor @AllDefaultTable
184+ `shouldEqual` "INSERT INTO behavior_defaults DEFAULT VALUES RETURNING *"
185+ (Schema.into allDefaultTable # Schema.insert {} # Schema.toSQL)
186+ `shouldEqual` "INSERT INTO behavior_defaults DEFAULT VALUES"
187+
188+ it "renders update entrypoint and all set-operation variants" do
189+ (Schema.update behaviorTable # Schema.set { name: "updated" } # Schema.where_ @"id = $id" # Schema.toSQL)
190+ `shouldEqual` "UPDATE behavior_values SET name = $1 WHERE id = $id"
191+ let left = Schema.from behaviorTable # Schema.select @"name"
192+ let right = Schema.from behaviorTable # Schema.select @"name"
193+ (left `Schema.intersectAll` right # Schema.toSQL)
194+ `shouldEqual` "(SELECT name FROM behavior_values) INTERSECT ALL (SELECT name FROM behavior_values)"
195+ (left `Schema.exceptAll` right # Schema.toSQL)
196+ `shouldEqual` "(SELECT name FROM behavior_values) EXCEPT ALL (SELECT name FROM behavior_values)"
197+
198+ it "renders CTEs and merges their named parameters" do
199+ let adults = Schema.cte @"adults" (Schema.from behaviorTable # Schema.select @"name" # Schema.where_ @"optional_int > $age")
200+ let mainQuery = Schema.fromCTE @"adults" adults # Schema.select @"name"
201+ (Schema.with_ adults mainQuery # Schema.toSQL)
202+ `shouldEqual` "WITH adults AS (SELECT name FROM behavior_values WHERE optional_int > $age) SELECT name FROM adults"
203+
204+ it "replaces repeated named parameters and preserves casts" do
205+ let replaced = Schema.replaceNamedParams 2
206+ [ { name: "id", value: unsafeToForeign 7 }
207+ , { name: "name", value: unsafeToForeign "Alice" }
208+ ]
209+ "id = $id::int OR parent_id = $id AND name = $name"
210+ replaced.sql `shouldEqual` "id = $3 OR parent_id = $3 AND name = $4"
211+ Array.length replaced.values `shouldEqual` 2
212+ Schema.stripCast "$id::uuid" `shouldEqual` "$id"
213+
214+ it "decodes rows and rejects mismatched result shapes" do
215+ let decoded = Schema.decodeRows
216+ [ unsafeToForeign { id: 1, name: "ok" }
217+ , unsafeToForeign { id: 2, name: "also ok" }
218+ ] :: Either _ (Array { id :: Int, name :: String })
219+ decoded `shouldEqual` Right [ { id: 1, name: "ok" }, { id: 2, name: "also ok" } ]
220+ let bad = Schema.decodeRow (unsafeToForeign { id: "wrong" }) :: Either _ { id :: Int }
221+ bad `shouldSatisfy` isLeft
222+ let fractionalTime = Schema.decodeRow (unsafeToForeign { value: "14:30:45.5" }) :: Either _ { value :: Schema.PGTime }
223+ fractionalTime `shouldEqual` Right { value: expectedHalfSecondTime }
224+
225+integrationSpec :: SpecT Aff PG.Connection Identity Unit
226+integrationSpec = do
227+ describe "How to use the public Postgres API" do
228+ it "reports query metadata and preserves heterogeneous and homogeneous parameters" \conn -> do
229+ result <- PG.query
230+ (PG.SQL "SELECT $1::int AS minimum, $2::int AS maximum, $3::double precision AS huge, $4::text AS first, $5::text AS second, $6::int[] AS integers")
231+ ( PG.param (bottom :: Int)
232+ <> PG.param (top :: Int)
233+ <> PG.param 1.5e200
234+ <> PG.params [ "first", "second" ]
235+ <> PG.param [ bottom :: Int, top :: Int ]
236+ )
237+ conn
238+ result.command `shouldEqual` "SELECT"
239+ result.count `shouldEqual` 1
240+ case Schema.decodeRows result.rows of
241+ Left errs -> throwError (error (show errs))
242+ Right rows -> rows `shouldEqual`
243+ [ { minimum: bottom :: Int
244+ , maximum: top :: Int
245+ , huge: 1.5e200
246+ , first: "first"
247+ , second: "second"
248+ , integers: [ bottom :: Int, top :: Int ]
249+ }
250+ ]
251+
252+ it "round-trips UUID, JSON, date, time, timestamp, arrays, and bigint rows" \conn -> do
253+ uuid <- liftEffect UUID.genUUID
254+ result <- PG.query
255+ (PG.SQL "SELECT $1::uuid AS uuid, $2::jsonb AS document, $3::date AS event_date, $4::time AS event_time, $5::timestamptz AS event_at, $6::text[] AS tags, $7::bigint AS big")
256+ [ PG.toPGValue uuid
257+ , PG.toPGValue (unsafeToForeign { key: "value", nested: { count: 2 } })
258+ , PG.toPGValue "2025-06-15"
259+ , PG.toPGValue "14:30:45.125"
260+ , PG.toPGValue "2025-01-15T12:00:00.000Z"
261+ , PG.toPGValue [ "a", "b" ]
262+ , PG.toPGValue "9223372036854775807"
263+ ]
264+ conn
265+ case Schema.decodeRows result.rows of
266+ Left errs -> throwError (error (show errs))
267+ Right rows -> rows `shouldEqual`
268+ [ { uuid: Schema.PGUUID uuid
269+ , document: { key: "value", nested: { count: 2 } }
270+ , event_date: expectedDate
271+ , event_time: expectedTime
272+ , event_at: expectedTimestamp
273+ , tags: [ "a", "b" ]
274+ , big: BigInt.fromString "9223372036854775807" # unsafePartial fromJust
275+ }
276+ ]
277+
278+ it "distinguishes query-one, unsafe exact-row, and no-row behavior" \conn -> do
279+ one <- PG.queryOneSimple (PG.SQL "SELECT 41::int AS value") conn
280+ case one of
281+ Nothing -> throwError (error "expected queryOneSimple row")
282+ Just row -> Schema.decodeRow row `shouldEqual` Right { value: 41 }
283+ exact <- PG.unsafe (PG.SQL "SELECT $1::int AS value") [ PG.toPGValue 42 ] conn
284+ Schema.decodeRow exact `shouldEqual` Right { value: 42 }
285+ missing <- PG.queryOneSimple (PG.SQL "SELECT 1 WHERE false") conn
286+ case missing of
287+ Nothing -> pure unit
288+ Just _ -> throwError (error "expected queryOneSimple to return Nothing")
289+ unsafeMissing <- try $ PG.unsafe (PG.SQL "SELECT 1 WHERE false") [] conn
290+ case unsafeMissing of
291+ Left _ -> pure unit
292+ Right _ -> throwError (error "expected unsafe to reject an empty result")
293+
294+ it "returns affected rows including zero matches" \conn -> do
295+ setupBehaviorTable conn
296+ inserted <- PG.execute (PG.SQL "INSERT INTO behavior_values (name) VALUES ($1), ($2)") (PG.params [ "a", "b" ]) conn
297+ inserted `shouldEqual` 2
298+ updated <- PG.execute (PG.SQL "UPDATE behavior_values SET name = $1 WHERE name = $2") (PG.params [ "updated", "missing" ]) conn
299+ updated `shouldEqual` 0
300+ deleted <- PG.executeSimple (PG.SQL "DELETE FROM behavior_values") conn
301+ deleted `shouldEqual` 2
302+
303+ it "executes typed queries, Maybe parameters, raw results, mutations, and decode errors" \conn -> do
304+ setupBehaviorTable conn
305+ rows <- (Typed.executeSql typedIntQuery { n: 7 } conn :: Aff (Either String (Array { n :: Int })))
306+ rows `shouldEqual` Right [ { n: 7 } ]
307+ nullable <- (Typed.executeSql typedMaybeQuery { value: Nothing } conn :: Aff (Either String (Array { value :: Maybe Int })))
308+ nullable `shouldEqual` Right [ { value: Nothing } ]
309+ raw <- Typed.executeSqlRaw typedIntQuery { n: 8 } conn
310+ raw.count `shouldEqual` 1
311+ one <- (Typed.executeSqlOne typedIntQuery { n: 9 } conn :: Aff (Either String (Maybe { n :: Int })))
312+ one `shouldEqual` Right (Just { n: 9 })
313+ noRows <- (Typed.executeSqlOne (sql $ combineBuilders "SELECT 1::int AS n WHERE false" "") {} conn :: Aff (Either String (Maybe { n :: Int })))
314+ noRows `shouldEqual` Right (Nothing :: Maybe { n :: Int })
315+ many <- (Typed.executeSqlOne (sql $ combineBuilders "SELECT generate_series(1, 2)::int AS n" "") {} conn :: Aff (Either String (Maybe { n :: Int })))
316+ many `shouldEqual` Right (Nothing :: Maybe { n :: Int })
317+ bad <- (Typed.executeSql typedBadDecodeQuery {} conn :: Aff (Either String (Array { n :: Int })))
318+ bad `shouldSatisfy` isLeft
319+ affected <- Typed.executeMutation typedMutationQuery { name: "typed" } conn
320+ affected `shouldEqual` 1
321+
322+ it "uses schema wrappers as typed query parameters" \conn -> do
323+ setupTemporalParamTable conn
324+ uuid <- liftEffect UUID.genUUID
325+ let pgUuid = Schema.PGUUID uuid
326+ let document = unsafeToForeign { key: "value", nested: { count: 2 } }
327+ _ <- PG.execute
328+ (PG.SQL "INSERT INTO behavior_temporal (document, event_at, event_date, event_time, label, uuid) VALUES ($1, $2, $3, $4, $5, $6)")
329+ [ PG.toPGValue document
330+ , PG.toPGValue "2025-01-15T12:00:00.000Z"
331+ , PG.toPGValue "2025-06-15"
332+ , PG.toPGValue "14:30:45.125"
333+ , PG.toPGValue "matched"
334+ , PG.toPGValue (UUID.toString uuid)
335+ ]
336+ conn
337+ byDate <- Schema.from temporalParamTable
338+ # Schema.select @"label"
339+ # Schema.where_ @"event_date = $date"
340+ # Schema.runQuery conn { date: expectedDate }
341+ byTime <- Schema.from temporalParamTable
342+ # Schema.select @"label"
343+ # Schema.where_ @"event_time = $time"
344+ # Schema.runQuery conn { time: expectedTime }
345+ byTimestamp <- Schema.from temporalParamTable
346+ # Schema.select @"label"
347+ # Schema.where_ @"event_at = $timestamp"
348+ # Schema.runQuery conn { timestamp: expectedTimestamp }
349+ byDocument <- Schema.from temporalParamTable
350+ # Schema.select @"label"
351+ # Schema.where_ @"document @> $document"
352+ # Schema.runQuery conn { document: Schema.Jsonb document }
353+ byDate `shouldEqual` [ { label: "matched" } ]
354+ byTime `shouldEqual` [ { label: "matched" } ]
355+ byTimestamp `shouldEqual` [ { label: "matched" } ]
356+ byDocument `shouldEqual` [ { label: "matched" } ]
357+ inserted <- Schema.into temporalParamTable
358+ # Schema.insert
359+ { document: Schema.Jsonb document
360+ , event_at: expectedTimestamp
361+ , event_date: expectedDate
362+ , event_time: expectedTime
363+ , label: "typed"
364+ , uuid: pgUuid
365+ }
366+ # Schema.runExecute conn {}
367+ inserted `shouldEqual` 1
368+ allRows <- PG.querySimple (PG.SQL "SELECT label FROM behavior_temporal ORDER BY label") conn
369+ decoded <- case Schema.decodeRows allRows.rows of
370+ Left errs -> throwError (error (show errs))
371+ Right values -> pure values
372+ decoded `shouldEqual` [ { label: "matched" }, { label: "typed" } ]
373+
374+ it "converts Just values through the inner field encoder" \conn -> do
375+ setupTemporalParamTable conn
376+ uuid <- liftEffect UUID.genUUID
377+ let document = unsafeToForeign { key: "nullable timestamp" }
378+ inserted <- Schema.into temporalParamTable
379+ # Schema.insert
380+ { document: Schema.Jsonb document
381+ , event_at: expectedTimestamp
382+ , event_date: expectedDate
383+ , event_time: expectedTime
384+ , label: "nullable"
385+ , optional_event_at: Just expectedTimestamp
386+ , uuid: Schema.PGUUID uuid
387+ }
388+ # Schema.runExecute conn {}
389+ inserted `shouldEqual` 1
390+ rows <- Schema.from temporalParamTable
391+ # Schema.select @"optional_event_at"
392+ # Schema.runQuery conn {}
393+ rows `shouldEqual` [ { optional_event_at: Just expectedTimestamp } ]
394+
395+ it "use begin/commit/rollback when transaction boundaries are explicit" \conn -> do
396+ setupTxTable conn
397+ committed <- PG.begin conn
398+ _ <- PG.txExecute (PG.SQL "INSERT INTO behavior_tx (name) VALUES ($1)") [ PG.toPGValue "committed" ] committed
399+ inTransaction <- PG.txQuery (PG.SQL "SELECT name FROM behavior_tx WHERE name = $1") [ PG.toPGValue "committed" ] committed
400+ inTransaction.count `shouldEqual` 1
401+ PG.commit committed
402+ afterCommit <- PG.querySimple (PG.SQL "SELECT name FROM behavior_tx") conn
403+ afterCommit.count `shouldEqual` 1
404+
405+ rolledBack <- PG.begin conn
406+ _ <- PG.txExecute (PG.SQL "INSERT INTO behavior_tx (name) VALUES ($1)") [ PG.toPGValue "rolled back" ] rolledBack
407+ PG.rollback rolledBack
408+ afterRollback <- PG.querySimple (PG.SQL "SELECT name FROM behavior_tx") conn
409+ afterRollback.count `shouldEqual` 1
410+
411+
412+ it "let transaction roll back SQL errors and return the connection to the pool" \conn -> do
413+ setupTxTable conn
414+ result <- try $ PG.withTransaction (\txn -> do
415+ _ <- PG.txExecute (PG.SQL "INSERT INTO behavior_tx (name) VALUES ($1)") [ PG.toPGValue "before error" ] txn
416+ _ <- PG.txExecute (PG.SQL "INSERT INTO missing_behavior_table VALUES ($1)") [ PG.toPGValue 1 ] txn
417+ pure unit
418+ ) conn
419+ result `shouldSatisfy` isLeft
420+ rows <- PG.querySimple (PG.SQL "SELECT * FROM behavior_tx") conn
421+ rows.count `shouldEqual` 0
422+ PG.ping conn >>= (_ `shouldEqual` true)
423+
424+ it "preserves the action failure when rollback also fails" \conn -> do
425+ result <- try $ PG.withTransaction
426+ (\txn -> do
427+ liftEffect $ poisonRollback txn
428+ throwError (error "action failed")
429+ )
430+ conn
431+ case result of
432+ Left cause -> message cause `shouldEqual` "action failed"
433+ Right _ -> throwError (error "expected transaction to fail")
434+ PG.ping conn >>= (_ `shouldEqual` true)
435+
436+ it "let transaction roll back cancellation and return the connection to the pool" \conn -> do
437+ setupTxTable conn
438+ wrote <- liftEffect $ Ref.new false
439+ fiber <- forkAff $ PG.withTransaction
440+ (\txn -> do
441+ _ <- PG.txExecute
442+ (PG.SQL "INSERT INTO behavior_tx (name) VALUES ($1)")
443+ [ PG.toPGValue "cancelled" ]
444+ txn
445+ liftEffect $ Ref.write true wrote
446+ delay (Milliseconds 10000.0)
447+ )
448+ conn
449+ delay (Milliseconds 50.0)
450+ didWrite <- liftEffect $ Ref.read wrote
451+ didWrite `shouldEqual` true
452+ killFiber (error "cancel transaction") fiber
453+ rows <- PG.querySimple (PG.SQL "SELECT * FROM behavior_tx") conn
454+ rows.count `shouldEqual` 0
455+ PG.ping conn >>= (_ `shouldEqual` true)
456+
457+ it "releases the reserved connection when commit itself fails" \_ -> do
458+ own <- liftEffect $ PG.postgres
459+ { host: PG.PostgresHost "localhost"
460+ , port: PG.PostgresPort 5434
461+ , database: PG.PostgresDatabase "test_playground"
462+ , username: PG.PostgresUsername "postgres"
463+ , password: PG.PostgresPassword "postgres"
464+ , max: PG.MaxConnections 1
465+ }
466+ _ <- PG.executeSimple (PG.SQL "DROP TABLE IF EXISTS behavior_commit_failure") own
467+ _ <- PG.executeSimple
468+ (PG.SQL "CREATE TABLE behavior_commit_failure (name TEXT UNIQUE DEFERRABLE INITIALLY DEFERRED)")
469+ own
470+ txn <- PG.begin own
471+ _ <- PG.txExecute
472+ (PG.SQL "INSERT INTO behavior_commit_failure (name) VALUES ($1), ($2)")
473+ [ PG.toPGValue "duplicate", PG.toPGValue "duplicate" ]
474+ txn
475+ commitResult <- try $ PG.commit txn
476+ commitResult `shouldSatisfy` isLeft
477+ PG.ping own >>= (_ `shouldEqual` true)
478+ PG.end own
479+
480+
481+ it "supports deterministic concurrent pool queries" \conn -> do
482+ setupBehaviorTable conn
483+ counts <- parTraverse
484+ (\n -> PG.execute (PG.SQL "INSERT INTO behavior_values (name) VALUES ($1)") [ PG.toPGValue ("worker-" <> show n) ] conn)
485+ (Array.range 1 8)
486+ counts `shouldEqual` Array.replicate 8 1
487+ rows <- PG.querySimple (PG.SQL "SELECT * FROM behavior_values") conn
488+ rows.count `shouldEqual` 8
489+
490+ it "delivers notifications and actually unsubscribes" \conn -> do
491+ received <- liftEffect $ Ref.new ([] :: Array String)
492+ let channel = PG.Channel "behavior_notifications"
493+ PG.listen channel (\notification -> Ref.modify_ (_ <> [ notification.payload ]) received) conn
494+ PG.notify channel "before-unlisten" conn
495+ delay (Milliseconds 100.0)
496+ liftEffect (Ref.read received) >>= (_ `shouldEqual` [ "before-unlisten" ])
497+ PG.unlisten channel conn
498+ PG.notify channel "after-unlisten" conn
499+ delay (Milliseconds 100.0)
500+ liftEffect (Ref.read received) >>= (_ `shouldEqual` [ "before-unlisten" ])
501+
502+ it "rejects missing and deallocated prepared statements" \conn -> do
503+ setupBehaviorTable conn
504+ let name = PG.StatementName "behavior_insert"
505+ missing <- try $ PG.executePrepared name [ PG.toPGValue "x" ] conn
506+ case missing of
507+ Left _ -> pure unit
508+ Right _ -> throwError (error "expected missing prepared statement to fail")
509+ PG.prepare name (PG.SQL "INSERT INTO behavior_values (name) VALUES ($1)") conn
510+ PG.executePrepared name [ PG.toPGValue "prepared" ] conn >>= (_.count >>> (_ `shouldEqual` 1))
511+ PG.deallocate name conn
512+ deallocated <- try $ PG.executePrepared name [ PG.toPGValue "again" ] conn
513+ case deallocated of
514+ Left _ -> pure unit
515+ Right _ -> throwError (error "expected deallocated prepared statement to fail")
516+
517+ it "invokes notice and parameter callbacks as PureScript Effects" \_ -> do
518+ noticeSeen <- liftEffect $ Ref.new false
519+ parameterSeen <- liftEffect $ Ref.new false
520+ callbackConn <- liftEffect $ PG.postgres
521+ { host: PG.PostgresHost "localhost"
522+ , port: PG.PostgresPort 5434
523+ , database: PG.PostgresDatabase "test_playground"
524+ , username: PG.PostgresUsername "postgres"
525+ , password: PG.PostgresPassword "postgres"
526+ , onnotice: Ref.write true noticeSeen
527+ , onparameter: \_ -> Ref.write true parameterSeen
528+ }
529+ _ <- PG.executeSimple (PG.SQL "DO $$ BEGIN RAISE NOTICE 'behavior callback'; END $$") callbackConn
530+ _ <- PG.executeSimple (PG.SQL "SET application_name TO 'yoga-postgres-callback-test'") callbackConn
531+ liftEffect (Ref.read noticeSeen) >>= (_ `shouldEqual` true)
532+ liftEffect (Ref.read parameterSeen) >>= (_ `shouldEqual` true)
533+ PG.end callbackConn
534+
535+ it "connects via connection string and end closes the pool" \_ -> do
536+ own <- liftEffect $ PG.postgres
537+ { connection: PG.ConnectionString "postgres://postgres:postgres@localhost:5434/test_playground" }
538+ PG.ping own >>= (_ `shouldEqual` true)
539+ PG.end own
540+ PG.ping own >>= (_ `shouldEqual` false)
test/EdgeCases.purs+2−1
@@ -3,6 +3,7 @@ module Test.Postgres.EdgeCases where
3import Prelude
3import Prelude
4
4
5import Data.Maybe (Maybe)
5import Data.Maybe (Maybe)
6+import JS.BigInt (BigInt)
6import Prim.Boolean (True)
7import Prim.Boolean (True)
7import Type.Function (type (#))
8import Type.Function (type (#))
8import Type.Proxy (Proxy(..))
9import Type.Proxy (Proxy(..))
@@ -34,7 +35,7 @@ postsTable = Proxy
34-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
35-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
35
36
36havingMergesWhereParams
37havingMergesWhereParams
37− :: Q _ (name :: String, cnt :: Int) (age :: Int, minCount :: Int) _
38+ :: Q _ (name :: String, cnt :: BigInt) (age :: Int, minCount :: Int) _
38havingMergesWhereParams = from usersTable
39havingMergesWhereParams = from usersTable
39 # select @"name, COUNT(*) AS cnt"
40 # select @"name, COUNT(*) AS cnt"
40 # where_ @"age > $age"
41 # where_ @"age > $age"
test/Integration.purs+12−4
@@ -15,17 +15,25 @@ main :: Effect Unit
15main = launchAff_ do
15main = launchAff_ do
16 conn <- liftEffect $ PG.postgres
16 conn <- liftEffect $ PG.postgres
17 { host: PG.PostgresHost "localhost"
17 { host: PG.PostgresHost "localhost"
18− , port: PG.PostgresPort 5433
18+ , port: PG.PostgresPort 5434
19 , database: PG.PostgresDatabase "test_playground"
19 , database: PG.PostgresDatabase "test_playground"
20 , username: PG.PostgresUsername "postgres"
20 , username: PG.PostgresUsername "postgres"
21 , password: PG.PostgresPassword "postgres"
21 , password: PG.PostgresPassword "postgres"
22 }
22 }
23− _ <- PG.executeSimple (PG.SQL "DROP TABLE IF EXISTS posts") conn
23+ _ <- PG.executeSimple (PG.SQL "DROP TABLE IF EXISTS sessions CASCADE") conn
24+ _ <- PG.executeSimple (PG.SQL "DROP TABLE IF EXISTS articles CASCADE") conn
25+ _ <- PG.executeSimple (PG.SQL "DROP TABLE IF EXISTS locations CASCADE") conn
26+ _ <- PG.executeSimple (PG.SQL "DROP TABLE IF EXISTS schedule CASCADE") conn
27+ _ <- PG.executeSimple (PG.SQL "DROP TABLE IF EXISTS posts CASCADE") conn
24− _ <- PG.executeSimple (PG.SQL "DROP TABLE IF EXISTS users") conn
28+ _ <- PG.executeSimple (PG.SQL "DROP TABLE IF EXISTS users CASCADE") conn
25− _ <- PG.executeSimple (PG.SQL "DROP TABLE IF EXISTS events") conn
29+ _ <- PG.executeSimple (PG.SQL "DROP TABLE IF EXISTS events CASCADE") conn
26 _ <- PG.executeSimple (PG.SQL (createTableDDL @Schema.UsersTable)) conn
30 _ <- PG.executeSimple (PG.SQL (createTableDDL @Schema.UsersTable)) conn
27 _ <- PG.executeSimple (PG.SQL (createTableDDL @Schema.EventsTable)) conn
31 _ <- PG.executeSimple (PG.SQL (createTableDDL @Schema.EventsTable)) conn
28 _ <- PG.executeSimple (PG.SQL (createTableDDL @Schema.PostsTable)) conn
32 _ <- PG.executeSimple (PG.SQL (createTableDDL @Schema.PostsTable)) conn
33+ _ <- PG.executeSimple (PG.SQL (createTableDDL @Schema.SessionsTable)) conn
34+ _ <- PG.executeSimple (PG.SQL (createTableDDL @Schema.ScheduleTable)) conn
35+ _ <- PG.executeSimple (PG.SQL (createTableDDL @Schema.LocationsTable)) conn
36+ _ <- PG.executeSimple (PG.SQL (createTableDDL @Schema.ArticlesTable)) conn
29 _ <- PG.execute (PG.SQL "INSERT INTO users (name, email, age) VALUES ($1, $2, $3)")
37 _ <- PG.execute (PG.SQL "INSERT INTO users (name, email, age) VALUES ($1, $2, $3)")
30 [ PG.toPGValue "Alice", PG.toPGValue "alice@example.com", PG.toPGValue 22 ]
38 [ PG.toPGValue "Alice", PG.toPGValue "alice@example.com", PG.toPGValue 22 ]
31 conn
39 conn
test/Main.purs+15−8
@@ -4,6 +4,7 @@ import Prelude
4
4
5import Data.Either (Either(..))
5import Data.Either (Either(..))
6import Data.Maybe (Maybe(..))
6import Data.Maybe (Maybe(..))
7+import Data.Time.Duration (Milliseconds(..))
7import Effect (Effect)
8import Effect (Effect)
8import Effect.Aff (Aff, bracket, launchAff_, throwError, try)
9import Effect.Aff (Aff, bracket, launchAff_, throwError, try)
9import Effect.Class (liftEffect)
10import Effect.Class (liftEffect)
@@ -11,6 +12,7 @@ import Effect.Console (log)
11import Effect.Exception (error)
12import Effect.Exception (error)
12import Test.Spec (Spec, around, describe, it)
13import Test.Spec (Spec, around, describe, it)
13import Test.Spec.Assertions (shouldEqual, shouldSatisfy)
14import Test.Spec.Assertions (shouldEqual, shouldSatisfy)
15+import Test.Postgres.Behavioral as Behavioral
14import Test.Spec.Reporter.Console (consoleReporter)
16import Test.Spec.Reporter.Console (consoleReporter)
15import Test.Spec.Runner (runSpec)
17import Test.Spec.Runner (runSpec)
16import Yoga.Test.Docker as Docker
18import Yoga.Test.Docker as Docker
@@ -22,7 +24,7 @@ testHost :: PG.PostgresHost
22testHost = PG.PostgresHost "localhost"
24testHost = PG.PostgresHost "localhost"
23
25
24testPort :: PG.PostgresPort
26testPort :: PG.PostgresPort
25−testPort = PG.PostgresPort 5433 -- Test port from docker-compose.test.yml
27+testPort = PG.PostgresPort 5434 -- Test port from docker-compose.test.yml
26
28
27testDatabase :: PG.PostgresDatabase
29testDatabase :: PG.PostgresDatabase
28testDatabase = PG.PostgresDatabase "test_playground"
30testDatabase = PG.PostgresDatabase "test_playground"
@@ -93,6 +95,11 @@ setupTableWithConstraints conn = do
93spec :: Spec Unit
95spec :: Spec Unit
94spec = do
96spec = do
95 Schema.spec
97 Schema.spec
98+ Behavioral.pureSpec
99+
100+ around withPostgres do
101+ Behavioral.integrationSpec
102+
96
103
97 describe "Yoga.Postgres Integration Tests" do
104 describe "Yoga.Postgres Integration Tests" do
98
105
@@ -106,7 +113,7 @@ spec = do
106 it "retrieves connection options" \conn -> do
113 it "retrieves connection options" \conn -> do
107 opts <- liftEffect $ PG.options conn
114 opts <- liftEffect $ PG.options conn
108 opts.host `shouldSatisfy` (_ /= "")
115 opts.host `shouldSatisfy` (_ /= "")
109− opts.port `shouldEqual` 5433
116+ opts.port `shouldEqual` 5434
110 opts.database `shouldEqual` "test_playground"
117 opts.database `shouldEqual` "test_playground"
111
118
112 describe "Connection Errors" do
119 describe "Connection Errors" do
@@ -233,7 +240,7 @@ spec = do
233 it "commits transactions successfully" \conn -> do
240 it "commits transactions successfully" \conn -> do
234 setupTestTable conn
241 setupTestTable conn
235
242
236− _ <- PG.transaction
243+ _ <- PG.withTransaction
237 ( \txn -> do
244 ( \txn -> do
238 _ <- PG.txExecute (PG.SQL "INSERT INTO test_users (name) VALUES ($1)")
245 _ <- PG.txExecute (PG.SQL "INSERT INTO test_users (name) VALUES ($1)")
239 [ PG.toPGValue "Henry" ]
246 [ PG.toPGValue "Henry" ]
@@ -251,12 +258,12 @@ spec = do
251 it "rolls back on errors" \conn -> do
258 it "rolls back on errors" \conn -> do
252 setupTestTable conn
259 setupTestTable conn
253
260
254− result <- try $ PG.transaction
261+ result <- try $ PG.withTransaction
255 ( \txn -> do
262 ( \txn -> do
256 _ <- PG.txExecute (PG.SQL "INSERT INTO test_users (name) VALUES ($1)")
263 _ <- PG.txExecute (PG.SQL "INSERT INTO test_users (name) VALUES ($1)")
257 [ PG.toPGValue "Jack" ]
264 [ PG.toPGValue "Jack" ]
258 txn
265 txn
259− throwError (error "Intentional error")
266+ (throwError (error "Intentional error") :: Aff Unit)
260 )
267 )
261 conn
268 conn
262
269
@@ -268,7 +275,7 @@ spec = do
268 it "queries within transaction" \conn -> do
275 it "queries within transaction" \conn -> do
269 setupTestTable conn
276 setupTestTable conn
270
277
271− _ <- PG.transaction
278+ _ <- PG.withTransaction
272 ( \txn -> do
279 ( \txn -> do
273 _ <- PG.txExecute (PG.SQL "INSERT INTO test_users (name) VALUES ($1)")
280 _ <- PG.txExecute (PG.SQL "INSERT INTO test_users (name) VALUES ($1)")
274 [ PG.toPGValue "Leo" ]
281 [ PG.toPGValue "Leo" ]
@@ -433,11 +440,11 @@ main = launchAff_ do
433 bracket
440 bracket
434 ( do
441 ( do
435 liftEffect $ log "Starting Postgres and waiting for it to be ready..."
442 liftEffect $ log "Starting Postgres and waiting for it to be ready..."
436− Docker.startService "packages/yoga-postgres/docker-compose.test.yml" 30
443+ Docker.startService (Docker.ComposeFile "docker-compose.test.yml") (Docker.Timeout (Milliseconds 30000.0))
437 liftEffect $ log "Postgres is ready!\n"
444 liftEffect $ log "Postgres is ready!\n"
438 )
445 )
439 ( \_ -> do
446 ( \_ -> do
440− Docker.stopService "packages/yoga-postgres/docker-compose.test.yml"
447+ Docker.stopService (Docker.ComposeFile "docker-compose.test.yml")
441 liftEffect $ log "Cleanup complete\n"
448 liftEffect $ log "Cleanup complete\n"
442 )
449 )
443 (\_ -> runSpec [ consoleReporter ] spec)
450 (\_ -> runSpec [ consoleReporter ] spec)
test/Schema.purs+220−10
@@ -2,11 +2,15 @@ module Test.Postgres.Schema where
2
2
3import Prelude
3import Prelude
4
4
5+import Data.Array as Array
5import Data.Date (canonicalDate)
6import Data.Date (canonicalDate)
6import Data.DateTime (DateTime(..))
7import Data.DateTime (DateTime(..))
7import Data.Enum (toEnum)
8import Data.Enum (toEnum)
8import Data.Maybe (Maybe(..), fromJust)
9import Data.Maybe (Maybe(..), fromJust)
10+import Data.Newtype (un)
11+import Data.String as String
9import Data.Time (Time(..))
12import Data.Time (Time(..))
13+import Data.UUID as UUID
10import Partial.Unsafe (unsafePartial)
14import Partial.Unsafe (unsafePartial)
11
15
12import Type.Function (type (#))
16import Type.Function (type (#))
@@ -176,6 +180,13 @@ typedWhereComplex
176 _
180 _
177typedWhereComplex = from usersTable # selectAll # where_ @"name = $name AND age > $age"
181typedWhereComplex = from usersTable # selectAll # where_ @"name = $name AND age > $age"
178
182
183+typedWhereStringLiteral
184+ :: Q _
185+ (age :: Maybe Int, email :: String, id :: Int, name :: String)
186+ (status :: String)
187+ _
188+typedWhereStringLiteral = from usersTable # selectAll # where_ @"name = $status AND email != 'test@example.com'"
189+
179typedSelectColsWhere
190typedSelectColsWhere
180 :: Q _
191 :: Q _
181 (name :: String)
192 (name :: String)
@@ -221,15 +232,15 @@ typedInsertReturning = from usersTable
221
232
222typedSet
233typedSet
223 :: Q _ () () _
234 :: Q _ () () _
224−typedSet = from usersTable # set { name: "Bob" }
235+typedSet = update usersTable # set { name: "Bob" }
225
236
226typedSetWhere
237typedSetWhere
227 :: Q _ () (id :: Int) _
238 :: Q _ () (id :: Int) _
228−typedSetWhere = from usersTable # set { name: "Bob" } # where_ @"id = $id"
239+typedSetWhere = update usersTable # set { name: "Bob" } # where_ @"id = $id"
229
240
230typedSetReturning
241typedSetReturning
231 :: Q _ (id :: Int, name :: String, email :: String) (id :: Int) _
242 :: Q _ (id :: Int, name :: String, email :: String) (id :: Int) _
232−typedSetReturning = from usersTable
243+typedSetReturning = update usersTable
233 # set { name: "Bob" }
244 # set { name: "Bob" }
234 # where_ @"id = $id"
245 # where_ @"id = $id"
235 # returning @"id, name, email"
246 # returning @"id, name, email"
@@ -429,7 +440,7 @@ typedGroupBy
429typedGroupBy = from usersTable # select @"name" # groupBy @"name"
440typedGroupBy = from usersTable # select @"name" # groupBy @"name"
430
441
431typedCountStar
442typedCountStar
432− :: Q _ (name :: String, cnt :: Int) () _
443+ :: Q _ (name :: String, cnt :: BigInt) () _
433typedCountStar = from usersTable
444typedCountStar = from usersTable
434 # select @"name, COUNT(*) AS cnt"
445 # select @"name, COUNT(*) AS cnt"
435 # groupBy @"name"
446 # groupBy @"name"
@@ -453,14 +464,14 @@ typedMinMax = from usersTable
453 # groupBy @"name"
464 # groupBy @"name"
454
465
455typedHaving
466typedHaving
456− :: Q _ (name :: String, cnt :: Int) (minCount :: Int) _
467+ :: Q _ (name :: String, cnt :: BigInt) (minCount :: Int) _
457typedHaving = from usersTable
468typedHaving = from usersTable
458 # select @"name, COUNT(*) AS cnt"
469 # select @"name, COUNT(*) AS cnt"
459 # groupBy @"name"
470 # groupBy @"name"
460 # having @"COUNT(*) > $minCount"
471 # having @"COUNT(*) > $minCount"
461
472
462typedFullAggregate
473typedFullAggregate
463− :: Q _ (name :: String, cnt :: Int) (min :: Int) _
474+ :: Q _ (name :: String, cnt :: BigInt) (min :: Int) _
464typedFullAggregate = from usersTable
475typedFullAggregate = from usersTable
465 # select @"name, COUNT(*) AS cnt"
476 # select @"name, COUNT(*) AS cnt"
466 # groupBy @"name"
477 # groupBy @"name"
@@ -469,7 +480,7 @@ typedFullAggregate = from usersTable
469 # limit @"10"
480 # limit @"10"
470
481
471typedWhereGroupByHaving
482typedWhereGroupByHaving
472− :: Q _ (name :: String, cnt :: Int) (age :: Int, minCount :: Int) _
483+ :: Q _ (name :: String, cnt :: BigInt) (age :: Int, minCount :: Int) _
473typedWhereGroupByHaving = from usersTable
484typedWhereGroupByHaving = from usersTable
474 # select @"name, COUNT(*) AS cnt"
485 # select @"name, COUNT(*) AS cnt"
475 # where_ @"age > $age"
486 # where_ @"age > $age"
@@ -636,6 +647,101 @@ typedCoalesceSelect
636typedCoalesceSelect = from usersTable
647typedCoalesceSelect = from usersTable
637 # select @"name, COALESCE(age, 0) AS val"
648 # select @"name, COALESCE(age, 0) AS val"
638
649
650+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
651+-- UUID + DefaultExpr
652+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
653+
654+type SessionsTable = Table "sessions"
655+ ( id :: PGUUID # PrimaryKey # DefaultExpr "gen_random_uuid()"
656+ , user_id :: Int # ForeignKey "users" References "id"
657+ , token :: String # Unique
658+ , created_at :: DateTime # DefaultExpr "now()"
659+ )
660+
661+sessionsTable :: Proxy SessionsTable
662+sessionsTable = Proxy
663+
664+sessionsDDL :: String
665+sessionsDDL = createTableDDL @SessionsTable
666+
667+sessionsInsertSQL :: String
668+sessionsInsertSQL = insertSQLFor @SessionsTable
669+
670+typedSessionSelect
671+ :: Q _ (id :: PGUUID, token :: String) () _
672+typedSessionSelect = from sessionsTable # select @"id, token"
673+
674+typedSessionWhere
675+ :: Q _ (id :: PGUUID, token :: String, user_id :: Int, created_at :: DateTime) (userId :: Int) _
676+typedSessionWhere = from sessionsTable # selectAll # where_ @"user_id = $userId"
677+
678+typedSessionInsert
679+ :: Q _ () () _
680+typedSessionInsert = from sessionsTable # insert { user_id: 42, token: "abc" }
681+
682+builderSessionSelect :: String
683+builderSessionSelect = typedSessionSelect # toSQL
684+
685+builderSessionInsert :: String
686+builderSessionInsert = typedSessionInsert # toSQL
687+
688+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
689+-- PGDate + PGTime
690+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
691+
692+type ScheduleTable = Table "schedule"
693+ ( id :: Int # PrimaryKey # AutoIncrement
694+ , event_date :: PGDate
695+ , start_time :: PGTime
696+ , title :: String
697+ )
698+
699+scheduleTable :: Proxy ScheduleTable
700+scheduleTable = Proxy
701+
702+scheduleDDL :: String
703+scheduleDDL = createTableDDL @ScheduleTable
704+
705+typedScheduleSelect
706+ :: Q _ (event_date :: PGDate, start_time :: PGTime, title :: String) () _
707+typedScheduleSelect = from scheduleTable # select @"event_date, start_time, title"
708+
709+typedScheduleWhere
710+ :: Q _ _ (d :: PGDate) _
711+typedScheduleWhere = from scheduleTable # selectAll # where_ @"event_date = $d"
712+
713+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
714+-- Point + TSVector + TSQuery
715+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
716+
717+type LocationsTable = Table "locations"
718+ ( id :: Int # PrimaryKey # AutoIncrement
719+ , name :: String
720+ , coords :: Point
721+ )
722+
723+locationsTable :: Proxy LocationsTable
724+locationsTable = Proxy
725+
726+locationsDDL :: String
727+locationsDDL = createTableDDL @LocationsTable
728+
729+type ArticlesTable = Table "articles"
730+ ( id :: Int # PrimaryKey # AutoIncrement
731+ , title :: String
732+ , body_vector :: TSVector
733+ )
734+
735+articlesTable :: Proxy ArticlesTable
736+articlesTable = Proxy
737+
738+articlesDDL :: String
739+articlesDDL = createTableDDL @ArticlesTable
740+
741+typedFTSWhere
742+ :: Q _ _ (q :: String) _
743+typedFTSWhere = from articlesTable # selectAll # where_ @"body_vector @@ to_tsquery($q)"
744+
639-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
745-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
640-- Spec
746-- Spec
641-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
747-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
@@ -665,7 +771,27 @@ spec = do
665 it "renders DEFAULT in DDL" do
771 it "renders DEFAULT in DDL" do
666 configDDL `shouldEqual` "CREATE TABLE config (active BOOLEAN NOT NULL DEFAULT true, id INTEGER NOT NULL GENERATED ALWAYS AS IDENTITY PRIMARY KEY, role TEXT NOT NULL DEFAULT 'user', score INTEGER NOT NULL DEFAULT 0)"
772 configDDL `shouldEqual` "CREATE TABLE config (active BOOLEAN NOT NULL DEFAULT true, id INTEGER NOT NULL GENERATED ALWAYS AS IDENTITY PRIMARY KEY, role TEXT NOT NULL DEFAULT 'user', score INTEGER NOT NULL DEFAULT 0)"
667 it "skips Default columns in INSERT" do
773 it "skips Default columns in INSERT" do
668− configInsertSQL `shouldEqual` "INSERT INTO config () VALUES () RETURNING *"
774+ configInsertSQL `shouldEqual` "INSERT INTO config DEFAULT VALUES RETURNING *"
775+
776+ describe "UUID + DefaultExpr" do
777+ it "renders UUID and DefaultExpr in DDL" do
778+ sessionsDDL `shouldEqual` "CREATE TABLE sessions (created_at TIMESTAMPTZ NOT NULL DEFAULT now(), id UUID NOT NULL DEFAULT gen_random_uuid() PRIMARY KEY, token TEXT NOT NULL UNIQUE, user_id INTEGER NOT NULL REFERENCES users(id))"
779+ it "skips DefaultExpr columns in INSERT" do
780+ sessionsInsertSQL `shouldEqual` "INSERT INTO sessions (token, user_id) VALUES ($1, $2) RETURNING *"
781+ it "builds SELECT with UUID column" do
782+ builderSessionSelect `shouldEqual` "SELECT id, token FROM sessions"
783+ it "builds INSERT skipping DefaultExpr columns" do
784+ builderSessionInsert `shouldEqual` "INSERT INTO sessions (token, user_id) VALUES ($1, $2)"
785+
786+ describe "PGDate + PGTime" do
787+ it "renders DATE and TIME in DDL" do
788+ scheduleDDL `shouldEqual` "CREATE TABLE schedule (event_date DATE NOT NULL, id INTEGER NOT NULL GENERATED ALWAYS AS IDENTITY PRIMARY KEY, start_time TIME NOT NULL, title TEXT NOT NULL)"
789+
790+ describe "Point + TSVector + TSQuery" do
791+ it "renders POINT in DDL" do
792+ locationsDDL `shouldEqual` "CREATE TABLE locations (coords POINT NOT NULL, id INTEGER NOT NULL GENERATED ALWAYS AS IDENTITY PRIMARY KEY, name TEXT NOT NULL)"
793+ it "renders TSVECTOR in DDL" do
794+ articlesDDL `shouldEqual` "CREATE TABLE articles (body_vector TSVECTOR NOT NULL, id INTEGER NOT NULL GENERATED ALWAYS AS IDENTITY PRIMARY KEY, title TEXT NOT NULL)"
669
795
670 describe "UPDATE SQL" do
796 describe "UPDATE SQL" do
671 it "generates UPDATE with SET and WHERE" do
797 it "generates UPDATE with SET and WHERE" do
@@ -944,7 +1070,7 @@ integrationSpec conn = do
944 describe "Builder update execution" do
1070 describe "Builder update execution" do
945 it "updates a row" do
1071 it "updates a row" do
946 resetUsers conn
1072 resetUsers conn
947− count <- from usersTable
1073+ count <- update usersTable
948 # set { email: "alice-updated@example.com" }
1074 # set { email: "alice-updated@example.com" }
949 # where_ @"name = $name"
1075 # where_ @"name = $name"
950 # runExecute conn { name: "Alice" }
1076 # runExecute conn { name: "Alice" }
@@ -956,7 +1082,7 @@ integrationSpec conn = do
956 result `shouldEqual` Just { email: "alice-updated@example.com" }
1082 result `shouldEqual` Just { email: "alice-updated@example.com" }
957
1083
958 it "updates with RETURNING" do
1084 it "updates with RETURNING" do
959− rows <- from usersTable
1085+ rows <- update usersTable
960 # set { age: Just 99 }
1086 # set { age: Just 99 }
961 # where_ @"name = $name"
1087 # where_ @"name = $name"
962 # returning @"name, age"
1088 # returning @"name, age"
@@ -1221,3 +1347,87 @@ integrationSpec conn = do
1221 # orderBy @"name"
1347 # orderBy @"name"
1222 # runQuery conn { age: 10, minCount: 0 }
1348 # runQuery conn { age: 10, minCount: 0 }
1223 rows `shouldEqual` [ { name: "Alice" }, { name: "Bob" } ]
1349 rows `shouldEqual` [ { name: "Alice" }, { name: "Bob" } ]
1350+
1351+ describe "UUID + DefaultExpr execution" do
1352+ it "creates sessions table from DDL" do
1353+ _ <- PG.executeSimple (PG.SQL "DELETE FROM sessions") conn
1354+ pure unit
1355+
1356+ it "inserts with server-generated UUID and timestamp" do
1357+ _ <- PG.executeSimple (PG.SQL "DELETE FROM sessions") conn
1358+ count <- from sessionsTable
1359+ # insert { user_id: 1, token: "sess-abc" }
1360+ # runExecute conn {}
1361+ count `shouldEqual` 1
1362+
1363+ it "selects back UUID column" do
1364+ rows <- from sessionsTable
1365+ # select @"id, token"
1366+ # where_ @"token = $token"
1367+ # runQuery conn { token: "sess-abc" }
1368+ let len = Array.length rows
1369+ len `shouldEqual` 1
1370+ do
1371+ let row = unsafePartial fromJust (Array.head rows)
1372+ let uuidStr = UUID.toString (un PGUUID row.id)
1373+ String.length uuidStr `shouldEqual` 36
1374+ row.token `shouldEqual` "sess-abc"
1375+
1376+ describe "PGDate + PGTime execution" do
1377+ it "round-trips date and time values" do
1378+ _ <- PG.executeSimple (PG.SQL "DELETE FROM schedule") conn
1379+ _ <- PG.executeSimple (PG.SQL "ALTER SEQUENCE schedule_id_seq RESTART WITH 1") conn
1380+ _ <- PG.execute
1381+ (PG.SQL "INSERT INTO schedule (event_date, start_time, title) VALUES ($1::date, $2::time, $3)")
1382+ [ PG.toPGValue "2025-06-15", PG.toPGValue "14:30:00", PG.toPGValue "Meeting" ]
1383+ conn
1384+ rows <- from scheduleTable
1385+ # select @"event_date, start_time, title"
1386+ # where_ @"title = $title"
1387+ # runQuery conn { title: "Meeting" }
1388+ let
1389+ expectedDate = unsafePartial do
1390+ let y = fromJust (toEnum 2025)
1391+ let m = fromJust (toEnum 6)
1392+ let d = fromJust (toEnum 15)
1393+ PGDate (canonicalDate y m d)
1394+ let
1395+ expectedTime = unsafePartial do
1396+ let h = fromJust (toEnum 14)
1397+ let mi = fromJust (toEnum 30)
1398+ let s = fromJust (toEnum 0)
1399+ let ms = fromJust (toEnum 0)
1400+ PGTime (Time h mi s ms)
1401+ rows `shouldEqual` [ { event_date: expectedDate, start_time: expectedTime, title: "Meeting" } ]
1402+
1403+ describe "Point execution" do
1404+ it "round-trips point values" do
1405+ _ <- PG.executeSimple (PG.SQL "DELETE FROM locations") conn
1406+ _ <- PG.executeSimple (PG.SQL "ALTER SEQUENCE locations_id_seq RESTART WITH 1") conn
1407+ _ <- PG.execute
1408+ (PG.SQL "INSERT INTO locations (name, coords) VALUES ($1, point($2, $3))")
1409+ [ PG.toPGValue "HQ", PG.toPGValue 40.7, PG.toPGValue (-74.0) ]
1410+ conn
1411+ rows <- from locationsTable
1412+ # select @"name, coords"
1413+ # where_ @"name = $name"
1414+ # runQuery conn { name: "HQ" }
1415+ rows `shouldEqual` [ { name: "HQ", coords: Point { x: 40.7, y: -74.0 } } ]
1416+
1417+ describe "TSVector + TSQuery execution" do
1418+ it "inserts and queries with full-text search" do
1419+ _ <- PG.executeSimple (PG.SQL "DELETE FROM articles") conn
1420+ _ <- PG.executeSimple (PG.SQL "ALTER SEQUENCE articles_id_seq RESTART WITH 1") conn
1421+ _ <- PG.execute
1422+ (PG.SQL "INSERT INTO articles (title, body_vector) VALUES ($1, to_tsvector($2))")
1423+ [ PG.toPGValue "PureScript Rocks", PG.toPGValue "purescript is a strongly typed functional language" ]
1424+ conn
1425+ _ <- PG.execute
1426+ (PG.SQL "INSERT INTO articles (title, body_vector) VALUES ($1, to_tsvector($2))")
1427+ [ PG.toPGValue "Haskell Guide", PG.toPGValue "haskell is a lazy functional language" ]
1428+ conn
1429+ rows <- from articlesTable
1430+ # select @"title"
1431+ # where_ @"body_vector @@ to_tsquery($q)"
1432+ # runQuery conn { q: "purescript" }
1433+ rows `shouldEqual` [ { title: "PureScript Rocks" } ]