git.iko.soy/squeal
on dev help sign in
Merge branch '0.4-exceptions' into 0.4-array+exceptions
commitb259049cdfb75edf3772cf70136ad8ef3a025e68 authorEitan Chatav <eitan.chatav@gmail.com> dateMon 13 Aug 2018, 20:11 (8 years ago) parent8dde22dd658e4b
10 files changed+954−25
compare with dev
unifiedsplit
RELEASE NOTES.md+10 squeal-postgresql/squeal-postgresql.cabal+18 squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+457−1 squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+46−19 squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+22−1 squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+202−2 squeal-postgresql/src/Squeal/PostgreSQL/Render.hs+13−1 squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+61−1 squeal-postgresql/test/Specs/ExceptionHandling.hs+118 squeal-postgresql/test/Specs/Specs.hs+7
RELEASE NOTES.md+10
@@ -1,5 +1,15 @@
11## RELEASE NOTES
22
3+### Version 0.3.2 - August 4, 2018
4+
5+Version 0.3.2 features extensive support for `JSON` functionality with
6+more than 50 new functions.
7+This work is entirely due to [Mike Ledger](https://github.com/mikeplus64)
8+who has been making terrific contributions to Squeal. Thanks!
9+We also got some examples in the documentation for pools submitted by
10+[Raveline](https://github.com/Raveline). I'm so pleased to be
11+getting pull requests and issue submissions from you all!
12+
313### Version 0.3.1 - July 7, 2018
414
515Version 0.3.1 of Squeal enables the "Scrap your Nils" trick for
squeal-postgresql/squeal-postgresql.cabal+18
@@ -71,6 +71,24 @@ test-suite squeal-postgresql-doctest
7171 base >= 4.10.0.0
7272 , doctest >= 0.11.4
7373
74+test-suite squeal-postgresql-specs
75+ default-language: Haskell2010
76+ type: exitcode-stdio-1.0
77+ hs-source-dirs: test/Specs
78+ ghc-options: -Wall -main-is Specs
79+ main-is: Specs.hs
80+ other-modules: ExceptionHandling
81+ build-depends:
82+ base >= 4.10.0.0
83+ , bytestring >= 0.10.8.2
84+ , generics-sop >= 0.3.1.0
85+ , hspec >= 2.4.8
86+ , squeal-postgresql
87+ , text >= 1.2.2.2
88+ , transformers >= 0.5.2.0
89+ , transformers-base >= 0.4.4
90+ , vector >= 0.12.0.1
91+
7492executable squeal-postgresql-example
7593 default-language: Haskell2010
7694 hs-source-dirs: exe
squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+457−1
@@ -11,6 +11,7 @@ Squeal expressions are the atoms used to build statements.
1111{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
1212{-# LANGUAGE
1313 AllowAmbiguousTypes
14+ , ConstraintKinds
1415 , DeriveGeneric
1516 , FlexibleContexts
1617 , FlexibleInstances
@@ -25,6 +26,7 @@ Squeal expressions are the atoms used to build statements.
2526 , TypeInType
2627 , TypeOperators
2728 , UndecidableInstances
29+ , RankNTypes
2830#-}
2931
3032module Squeal.PostgreSQL.Expression
@@ -48,6 +50,7 @@ module Squeal.PostgreSQL.Expression
4850 , unsafeBinaryOp
4951 , unsafeUnaryOp
5052 , unsafeFunction
53+ , unsafeVariadicFunction
5154 , atan2_
5255 , cast
5356 , quot_
@@ -83,6 +86,53 @@ module Squeal.PostgreSQL.Expression
8386 , upper
8487 , charLength
8588 , like
89+ -- ** json or jsonb operators
90+ , PGarray
91+ , PGarrayOf
92+ , PGjsonKey
93+ , PGjson_
94+ , (.->)
95+ , (.->>)
96+ , (.#>)
97+ , (.#>>)
98+ -- *** jsonb only operators
99+ , (.@>)
100+ , (.<@)
101+ , (.?)
102+ , (.?|)
103+ , (.?&)
104+ , (.-.)
105+ , (#-.)
106+ -- *** Functions
107+ , jsonLit
108+ , jsonbLit
109+ , toJson
110+ , toJsonb
111+ , arrayToJson
112+ , rowToJson
113+ , jsonBuildArray
114+ , jsonbBuildArray
115+ , jsonBuildObject
116+ , jsonbBuildObject
117+ , jsonObject
118+ , jsonbObject
119+ , jsonZipObject
120+ , jsonbZipObject
121+ , jsonArrayLength
122+ , jsonbArrayLength
123+ , jsonExtractPath
124+ , jsonbExtractPath
125+ , jsonExtractPathAsText
126+ , jsonbExtractPathAsText
127+ , jsonObjectKeys
128+ , jsonbObjectKeys
129+ , jsonTypeof
130+ , jsonbTypeof
131+ , jsonStripNulls
132+ , jsonbStripNulls
133+ , jsonbSet
134+ , jsonbInsert
135+ , jsonbPretty
86136 -- ** Aggregation
87137 , unsafeAggregate, unsafeAggregateDistinct
88138 , sum_, sumDistinct
@@ -135,8 +185,10 @@ module Squeal.PostgreSQL.Expression
135185import Control.Category
136186import Control.DeepSeq
137187import Data.ByteString (ByteString)
188+import Data.ByteString.Lazy (toStrict)
138189import Data.Function ((&))
139−import Data.Semigroup
190+import Data.Semigroup hiding (All)
191+import qualified Data.Aeson as JSON
140192import Data.Ratio
141193import Data.String
142194import Generics.SOP hiding (from)
@@ -482,6 +534,16 @@ unsafeFunction
482534unsafeFunction fun x = UnsafeExpression $
483535 fun <> parenthesized (renderExpression x)
484536
537+-- | Helper for defining variadic functions.
538+unsafeVariadicFunction
539+ :: SListI elems
540+ => ByteString
541+ -- ^ function
542+ -> NP (Expression schema relations grouping params) elems
543+ -> Expression schema relations grouping params ret
544+unsafeVariadicFunction fun x = UnsafeExpression $
545+ fun <> parenthesized (commaSeparated (hcollapse (hmap (K . renderExpression) x)))
546+
485547instance PGNum ty
486548 => Num (Expression schema relations grouping params (nullity ty)) where
487549 (+) = unsafeBinaryOp "+"
@@ -870,6 +932,400 @@ like
870932 -> Expression schema relations grouping params (nullity 'PGbool)
871933like = unsafeBinaryOp "LIKE"
872934
935+{-----------------------------------------
936+ -- json and jsonb support
937+
938+See https://www.postgresql.org/docs/10/static/functions-json.html -- most
939+comments lifted directly from this page.
940+
941+Table 9.44: json and jsonb operators
942+-----------------------------------------}
943+
944+-- | Get JSON value (object field or array element) at a key.
945+(.->)
946+ :: (PGjson_ json, PGjsonKey key)
947+ => Expression schema relations grouping params (nullity json)
948+ -> Expression schema relations grouping params (nullity key)
949+ -> Expression schema relations grouping params ('Null json)
950+(.->) = unsafeBinaryOp "->"
951+
952+-- | Get JSON value (object field or array element) at a key, as text.
953+(.->>)
954+ :: (PGjson_ json, PGjsonKey key)
955+ => Expression schema relations grouping params (nullity json)
956+ -> Expression schema relations grouping params (nullity key)
957+ -> Expression schema relations grouping params ('Null 'PGtext)
958+(.->>) = unsafeBinaryOp "->>"
959+
960+-- | Get JSON value at a specified path.
961+(.#>)
962+ :: (PGjson_ json, PGtextArray "(.#>)" path)
963+ => Expression schema relations grouping params (nullity json)
964+ -> Expression schema relations grouping params (nullity path)
965+ -> Expression schema relations grouping params ('Null json)
966+(.#>) = unsafeBinaryOp "#>"
967+
968+-- | Get JSON value at a specified path as text.
969+(.#>>)
970+ :: (PGjson_ json, PGtextArray "(.#>>)" path)
971+ => Expression schema relations grouping params (nullity json)
972+ -> Expression schema relations grouping params (nullity path)
973+ -> Expression schema relations grouping params ('Null 'PGtext)
974+(.#>>) = unsafeBinaryOp "#>>"
975+
976+-- Additional jsonb operators
977+
978+-- | Does the left JSON value contain the right JSON path/value entries at the
979+-- top level?
980+(.@>)
981+ :: Expression schema relations grouping params (nullity 'PGjsonb)
982+ -> Expression schema relations grouping params (nullity 'PGjsonb)
983+ -> Condition schema relations grouping params
984+(.@>) = unsafeBinaryOp "@>"
985+
986+-- | Are the left JSON path/value entries contained at the top level within the
987+-- right JSON value?
988+(.<@)
989+ :: Expression schema relations grouping params (nullity 'PGjsonb)
990+ -> Expression schema relations grouping params (nullity 'PGjsonb)
991+ -> Condition schema relations grouping params
992+(.<@) = unsafeBinaryOp "<@"
993+
994+-- | Does the string exist as a top-level key within the JSON value?
995+(.?)
996+ :: Expression schema relations grouping params (nullity 'PGjsonb)
997+ -> Expression schema relations grouping params (nullity 'PGtext)
998+ -> Condition schema relations grouping params
999+(.?) = unsafeBinaryOp "?"
1000+
1001+-- | Do any of these array strings exist as top-level keys?
1002+(.?|)
1003+ :: Expression schema relations grouping params (nullity 'PGjsonb)
1004+ -> Expression schema relations grouping params (nullity ('PGvararray ('NotNull 'PGtext)))
1005+ -> Condition schema relations grouping params
1006+(.?|) = unsafeBinaryOp "?|"
1007+
1008+-- | Do all of these array strings exist as top-level keys?
1009+(.?&)
1010+ :: Expression schema relations grouping params (nullity 'PGjsonb)
1011+ -> Expression schema relations grouping params (nullity ('PGvararray ('NotNull 'PGtext)))
1012+ -> Condition schema relations grouping params
1013+(.?&) = unsafeBinaryOp "?&"
1014+
1015+-- | Concatenate two jsonb values into a new jsonb value.
1016+instance
1017+ Semigroup (Expression schema relations grouping param (nullity 'PGjsonb)) where
1018+ (<>) = unsafeBinaryOp "||"
1019+
1020+-- | Delete a key or keys from a JSON object, or remove an array element.
1021+--
1022+-- If the right operand is..
1023+--
1024+-- @ text @: Delete key/value pair or string element from left operand. Key/value pairs
1025+-- are matched based on their key value.
1026+--
1027+-- @ text[] @: Delete multiple key/value pairs or string elements
1028+-- from left operand. Key/value pairs are matched based on their key value.
1029+--
1030+-- @ integer @: Delete the array element with specified index (Negative integers
1031+-- count from the end). Throws an error if top level container is not an array.
1032+(.-.)
1033+ :: (key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]) -- hlint error without parens here
1034+ => Expression schema relations grouping params (nullity 'PGjsonb)
1035+ -> Expression schema relations grouping params (nullity key)
1036+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1037+(.-.) = unsafeBinaryOp "-"
1038+
1039+-- | Delete the field or element with specified path (for JSON arrays, negative
1040+-- integers count from the end)
1041+(#-.)
1042+ :: PGtextArray "(#-.)" arrayty
1043+ => Expression schema relations grouping params (nullity 'PGjsonb)
1044+ -> Expression schema relations grouping params (nullity arrayty)
1045+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1046+(#-.) = unsafeBinaryOp "#-"
1047+
1048+{-----------------------------------------
1049+Table 9.45: JSON creation functions
1050+-----------------------------------------}
1051+
1052+-- | Literal binary JSON
1053+jsonbLit :: JSON.Value -> Expression schema relations grouping params (nullity 'PGjsonb)
1054+jsonbLit = cast jsonb . UnsafeExpression . singleQuotedUtf8 . toStrict . JSON.encode
1055+
1056+-- | Literal JSON
1057+jsonLit :: JSON.Value -> Expression schema relations grouping params (nullity 'PGjson)
1058+jsonLit = cast json . UnsafeExpression . singleQuotedUtf8 . toStrict . JSON.encode
1059+
1060+-- | Returns the value as json. Arrays and composites are converted
1061+-- (recursively) to arrays and objects; otherwise, if there is a cast from the
1062+-- type to json, the cast function will be used to perform the conversion;
1063+-- otherwise, a scalar value is produced. For any scalar type other than a
1064+-- number, a Boolean, or a null value, the text representation will be used, in
1065+-- such a fashion that it is a valid json value.
1066+toJson
1067+ :: Expression schema relations grouping params (nullity ty)
1068+ -> Expression schema relations grouping params (nullity 'PGjson)
1069+toJson = unsafeFunction "to_json"
1070+
1071+-- | Returns the value as jsonb. Arrays and composites are converted
1072+-- (recursively) to arrays and objects; otherwise, if there is a cast from the
1073+-- type to json, the cast function will be used to perform the conversion;
1074+-- otherwise, a scalar value is produced. For any scalar type other than a
1075+-- number, a Boolean, or a null value, the text representation will be used, in
1076+-- such a fashion that it is a valid jsonb value.
1077+toJsonb
1078+ :: Expression schema relations grouping params (nullity ty)
1079+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1080+toJsonb = unsafeFunction "to_jsonb"
1081+
1082+-- | Returns the array as a JSON array. A PostgreSQL multidimensional array
1083+-- becomes a JSON array of arrays.
1084+arrayToJson
1085+ :: PGarray "arrayToJson" arr
1086+ => Expression schema relations grouping params (nullity arr)
1087+ -> Expression schema relations grouping params (nullity 'PGjson)
1088+arrayToJson = unsafeFunction "array_to_json"
1089+
1090+-- | Returns the row as a JSON object.
1091+rowToJson
1092+ :: Expression schema relations grouping params (nullity ('PGcomposite ty))
1093+ -> Expression schema relations grouping params (nullity 'PGjson)
1094+rowToJson = unsafeFunction "row_to_json"
1095+
1096+-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic
1097+-- argument list.
1098+jsonBuildArray
1099+ :: SListI elems
1100+ => NP (Expression schema relations grouping params) elems
1101+ -> Expression schema relations grouping params (nullity 'PGjson)
1102+jsonBuildArray = unsafeVariadicFunction "json_build_array"
1103+
1104+-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a
1105+-- variadic argument list.
1106+jsonbBuildArray
1107+ :: SListI elems
1108+ => NP (Expression schema relations grouping params) elems
1109+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1110+jsonbBuildArray = unsafeVariadicFunction "jsonb_build_array"
1111+
1112+unsafeRowFunction
1113+ :: All Top elems
1114+ => NP (Aliased (Expression schema relations grouping params)) elems
1115+ -> [ByteString]
1116+unsafeRowFunction =
1117+ (`appEndo` []) . hcfoldMap (Proxy :: Proxy Top)
1118+ (\(col `As` name) -> Endo $ \xs ->
1119+ renderAliasString name : renderExpression col : xs)
1120+
1121+-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic
1122+-- argument list. The elements of the argument list must alternate between text
1123+-- and values.
1124+jsonBuildObject
1125+ :: All Top elems
1126+ => NP (Aliased (Expression schema relations grouping params)) elems
1127+ -> Expression schema relations grouping params (nullity 'PGjson)
1128+jsonBuildObject
1129+ = unsafeFunction "json_build_object"
1130+ . UnsafeExpression
1131+ . commaSeparated
1132+ . unsafeRowFunction
1133+
1134+-- | Builds a possibly-heterogeneously-typed (binary) JSON object out of a
1135+-- variadic argument list. The elements of the argument list must alternate
1136+-- between text and values.
1137+jsonbBuildObject
1138+ :: All Top elems
1139+ => NP (Aliased (Expression schema relations grouping params)) elems
1140+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1141+jsonbBuildObject
1142+ = unsafeFunction "jsonb_build_object"
1143+ . UnsafeExpression
1144+ . commaSeparated
1145+ . unsafeRowFunction
1146+
1147+-- | Builds a JSON object out of a text array. The array must have either
1148+-- exactly one dimension with an even number of members, in which case they are
1149+-- taken as alternating key/value pairs, or two dimensions such that each inner
1150+-- array has exactly two elements, which are taken as a key/value pair.
1151+jsonObject
1152+ :: PGarrayOf "jsonObject" arr ('NotNull 'PGtext)
1153+ => Expression schema relations grouping params (nullity arr)
1154+ -> Expression schema relations grouping params (nullity 'PGjson)
1155+jsonObject = unsafeFunction "json_object"
1156+
1157+-- | Builds a binary JSON object out of a text array. The array must have either
1158+-- exactly one dimension with an even number of members, in which case they are
1159+-- taken as alternating key/value pairs, or two dimensions such that each inner
1160+-- array has exactly two elements, which are taken as a key/value pair.
1161+jsonbObject
1162+ :: PGarrayOf "jsonbObject" arr ('NotNull 'PGtext)
1163+ => Expression schema relations grouping params (nullity arr)
1164+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1165+jsonbObject = unsafeFunction "jsonb_object"
1166+
1167+-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
1168+-- keys and one for values, that are zipped pairwise to create a JSON object.
1169+jsonZipObject
1170+ :: ( PGarrayOf "jsonZipObject" keysArray ('NotNull 'PGtext)
1171+ , PGarrayOf "jsonZipObject" valuesArray ('NotNull 'PGtext))
1172+ => Expression schema relations grouping params (nullity keysArray)
1173+ -> Expression schema relations grouping params (nullity valuesArray)
1174+ -> Expression schema relations grouping params (nullity 'PGjson)
1175+jsonZipObject ks vs =
1176+ unsafeVariadicFunction "json_object" (ks :* vs :* Nil)
1177+
1178+-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
1179+-- keys and one for values, that are zipped pairwise to create a binary JSON
1180+-- object.
1181+jsonbZipObject
1182+ :: ( PGarrayOf "jsonbZipObject" keysArray ('NotNull 'PGtext)
1183+ , PGarrayOf "jsonbZipObject" valuesArray ('NotNull 'PGtext))
1184+ => Expression schema relations grouping params (nullity keysArray)
1185+ -> Expression schema relations grouping params (nullity valuesArray)
1186+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1187+jsonbZipObject ks vs =
1188+ unsafeVariadicFunction "jsonb_object" (ks :* vs :* Nil)
1189+
1190+{-----------------------------------------
1191+Table 9.46: JSON processing functions
1192+-----------------------------------------}
1193+
1194+-- | Returns the number of elements in the outermost JSON array.
1195+jsonArrayLength
1196+ :: Expression schema relations grouping params (nullity 'PGjson)
1197+ -> Expression schema relations grouping params (nullity 'PGint4)
1198+jsonArrayLength = unsafeFunction "json_array_length"
1199+
1200+-- | Returns the number of elements in the outermost binary JSON array.
1201+jsonbArrayLength
1202+ :: Expression schema relations grouping params (nullity 'PGjsonb)
1203+ -> Expression schema relations grouping params (nullity 'PGint4)
1204+jsonbArrayLength = unsafeFunction "jsonb_array_length"
1205+
1206+-- | Returns JSON value pointed to by the given path (equivalent to #>
1207+-- operator).
1208+jsonExtractPath
1209+ :: SListI elems
1210+ => Expression schema relations grouping params (nullity 'PGjson)
1211+ -> NP (Expression schema relations grouping params) elems
1212+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1213+jsonExtractPath x xs =
1214+ unsafeVariadicFunction "json_extract_path" (x :* xs)
1215+
1216+-- | Returns JSON value pointed to by the given path (equivalent to #>
1217+-- operator).
1218+jsonbExtractPath
1219+ :: SListI elems
1220+ => Expression schema relations grouping params (nullity 'PGjsonb)
1221+ -> NP (Expression schema relations grouping params) elems
1222+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1223+jsonbExtractPath x xs =
1224+ unsafeVariadicFunction "jsonb_extract_path" (x :* xs)
1225+
1226+-- | Returns JSON value pointed to by the given path (equivalent to #>
1227+-- operator), as text.
1228+jsonExtractPathAsText
1229+ :: SListI elems
1230+ => Expression schema relations grouping params (nullity 'PGjson)
1231+ -> NP (Expression schema relations grouping params) elems
1232+ -> Expression schema relations grouping params (nullity 'PGjson)
1233+jsonExtractPathAsText x xs =
1234+ unsafeVariadicFunction "json_extract_path_text" (x :* xs)
1235+
1236+-- | Returns JSON value pointed to by the given path (equivalent to #>
1237+-- operator), as text.
1238+jsonbExtractPathAsText
1239+ :: SListI elems
1240+ => Expression schema relations grouping params (nullity 'PGjsonb)
1241+ -> NP (Expression schema relations grouping params) elems
1242+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1243+jsonbExtractPathAsText x xs =
1244+ unsafeVariadicFunction "jsonb_extract_path_text" (x :* xs)
1245+
1246+-- | Returns set of keys in the outermost JSON object.
1247+jsonObjectKeys
1248+ :: Expression schema relations grouping params (nullity 'PGjson)
1249+ -> Expression schema relations grouping params (nullity 'PGtext)
1250+jsonObjectKeys = unsafeFunction "json_object_keys"
1251+
1252+-- | Returns set of keys in the outermost JSON object.
1253+jsonbObjectKeys
1254+ :: Expression schema relations grouping params (nullity 'PGjsonb)
1255+ -> Expression schema relations grouping params (nullity 'PGtext)
1256+jsonbObjectKeys = unsafeFunction "jsonb_object_keys"
1257+
1258+-- | Returns the type of the outermost JSON value as a text string. Possible
1259+-- types are object, array, string, number, boolean, and null.
1260+jsonTypeof
1261+ :: Expression schema relations grouping params (nullity 'PGjson)
1262+ -> Expression schema relations grouping params (nullity 'PGtext)
1263+jsonTypeof = unsafeFunction "json_typeof"
1264+
1265+-- | Returns the type of the outermost binary JSON value as a text string.
1266+-- Possible types are object, array, string, number, boolean, and null.
1267+jsonbTypeof
1268+ :: Expression schema relations grouping params (nullity 'PGjsonb)
1269+ -> Expression schema relations grouping params (nullity 'PGtext)
1270+jsonbTypeof = unsafeFunction "jsonb_typeof"
1271+
1272+-- | Returns its argument with all object fields that have null values omitted.
1273+-- Other null values are untouched.
1274+jsonStripNulls
1275+ :: Expression schema relations grouping params (nullity 'PGjson)
1276+ -> Expression schema relations grouping params (nullity 'PGjson)
1277+jsonStripNulls = unsafeFunction "json_strip_nulls"
1278+
1279+-- | Returns its argument with all object fields that have null values omitted.
1280+-- Other null values are untouched.
1281+jsonbStripNulls
1282+ :: Expression schema relations grouping params (nullity 'PGjsonb)
1283+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1284+jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"
1285+
1286+-- | @ jsonbSet target path new_value create_missing @
1287+--
1288+-- Returns target with the section designated by path replaced by new_value,
1289+-- or with new_value added if create_missing is true ( default is true) and the
1290+-- item designated by path does not exist. As with the path orientated
1291+-- operators, negative integers that appear in path count from the end of JSON
1292+-- arrays.
1293+jsonbSet
1294+ :: PGtextArray "jsonbSet" arr
1295+ => Expression schema relations grouping params (nullity 'PGjsonb)
1296+ -> Expression schema relations grouping params (nullity arr)
1297+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1298+ -> Maybe (Expression schema relations grouping params (nullity 'PGbool))
1299+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1300+jsonbSet tgt path val createMissing = case createMissing of
1301+ Just m -> unsafeVariadicFunction "jsonb_set" (tgt :* path :* val :* m :* Nil)
1302+ Nothing -> unsafeVariadicFunction "jsonb_set" (tgt :* path :* val :* Nil)
1303+
1304+-- | @ jsonbInsert target path new_value insert_after @
1305+--
1306+-- Returns target with new_value inserted. If target section designated by
1307+-- path is in a JSONB array, new_value will be inserted before target or after
1308+-- if insert_after is true (default is false). If target section designated by
1309+-- path is in JSONB object, new_value will be inserted only if target does not
1310+-- exist. As with the path orientated operators, negative integers that appear
1311+-- in path count from the end of JSON arrays.
1312+jsonbInsert
1313+ :: PGtextArray "jsonbInsert" arr
1314+ => Expression schema relations grouping params (nullity 'PGjsonb)
1315+ -> Expression schema relations grouping params (nullity arr)
1316+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1317+ -> Maybe (Expression schema relations grouping params (nullity 'PGbool))
1318+ -> Expression schema relations grouping params (nullity 'PGjsonb)
1319+jsonbInsert tgt path val insertAfter = case insertAfter of
1320+ Just i -> unsafeVariadicFunction "jsonb_insert" (tgt :* path :* val :* i :* Nil)
1321+ Nothing -> unsafeVariadicFunction "jsonb_insert" (tgt :* path :* val :* Nil)
1322+
1323+-- | Returns its argument as indented JSON text.
1324+jsonbPretty
1325+ :: Expression schema relations grouping params (nullity 'PGjsonb)
1326+ -> Expression schema relations grouping params (nullity 'PGtext)
1327+jsonbPretty = unsafeFunction "jsonb_pretty"
1328+
8731329{-----------------------------------------
8741330aggregation
8751331-----------------------------------------}
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+46−19
@@ -62,6 +62,8 @@ module Squeal.PostgreSQL.PQ
6262 , LibPQ.ExecStatus (..)
6363 , resultStatus
6464 , resultErrorMessage
65+ , resultErrorCode
66+ , SquealException (..)
6567 ) where
6668
6769import Control.Exception.Lifted
@@ -403,7 +405,9 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)
403405 case resultMaybe of
404406 Nothing -> error
405407 "manipulateParams: LibPQ.execParams returned no results"
406− Just result -> return $ K (K result)
408+ Just result -> do
409+ tryResult result
410+ return $ K (K result)
407411
408412 traversePrepared
409413 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =
@@ -413,10 +417,7 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)
413417 case prepResultMaybe of
414418 Nothing -> error
415419 "traversePrepared: LibPQ.prepare returned no results"
416− Just prepResult -> do
417− status <- LibPQ.resultStatus prepResult
418− unless (status == LibPQ.CommandOk) . error $
419− "traversePrepared: LibPQ.prepare status " <> show status
420+ Just prepResult -> tryResult prepResult
420421 results <- for list $ \ params -> do
421422 let
422423 toParam' encoding = (encodingBytes encoding,LibPQ.Binary)
@@ -425,15 +426,14 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)
425426 case resultMaybe of
426427 Nothing -> error
427428 "traversePrepared: LibPQ.execParams returned no results"
428− Just result -> return $ K result
429+ Just result -> do
430+ tryResult result
431+ return $ K result
429432 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
430433 case deallocResultMaybe of
431434 Nothing -> error
432435 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
433− Just deallocResult -> do
434− status <- LibPQ.resultStatus deallocResult
435− unless (status == LibPQ.CommandOk) . error $
436− "traversePrepared: DEALLOCATE status " <> show status
436+ Just deallocResult -> tryResult deallocResult
437437 return (K results)
438438
439439 traversePrepared_
@@ -444,10 +444,7 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)
444444 case prepResultMaybe of
445445 Nothing -> error
446446 "traversePrepared_: LibPQ.prepare returned no results"
447− Just prepResult -> do
448− status <- LibPQ.resultStatus prepResult
449− unless (status == LibPQ.CommandOk) . error $
450− "traversePrepared: LibPQ.prepare status " <> show status
447+ Just prepResult -> tryResult prepResult
451448 for_ list $ \ params -> do
452449 let
453450 toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
@@ -456,15 +453,12 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)
456453 case resultMaybe of
457454 Nothing -> error
458455 "traversePrepared_: LibPQ.execParams returned no results"
459− Just _result -> return ()
456+ Just result -> tryResult result
460457 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
461458 case deallocResultMaybe of
462459 Nothing -> error
463460 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
464− Just deallocResult -> do
465− status <- LibPQ.resultStatus deallocResult
466− unless (status == LibPQ.CommandOk) . error $
467− "traversePrepared: DEALLOCATE status " <> show status
461+ Just deallocResult -> tryResult deallocResult
468462 return (K ())
469463
470464 liftPQ pq = PQ $ \ (K conn) -> do
@@ -620,3 +614,36 @@ resultStatus = liftResult LibPQ.resultStatus
620614resultErrorMessage
621615 :: MonadBase IO io => K LibPQ.Result results -> io (Maybe ByteString)
622616resultErrorMessage = liftResult LibPQ.resultErrorMessage
617+
618+-- | Returns the error code most recently generated by an operation
619+-- on the connection.
620+--
621+-- https://www.postgresql.org/docs/current/static/errcodes-appendix.html
622+resultErrorCode
623+ :: MonadBase IO io
624+ => K LibPQ.Result results
625+ -> io (Maybe ByteString)
626+resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate)
627+
628+data SquealException
629+ = SquealException
630+ { sqlExecStatus :: LibPQ.ExecStatus
631+ , sqlStateCode :: Maybe ByteString
632+ -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html
633+ , sqlErrorMessage :: Maybe ByteString
634+ } deriving (Eq, Show)
635+instance Exception SquealException
636+
637+tryResult
638+ :: MonadBase IO io
639+ => LibPQ.Result
640+ -> io ()
641+tryResult result = liftBase $ do
642+ status <- LibPQ.resultStatus result
643+ case status of
644+ LibPQ.CommandOk -> return ()
645+ LibPQ.TuplesOk -> return ()
646+ _ -> do
647+ stateCode <- LibPQ.resultErrorField result LibPQ.DiagSqlstate
648+ msg <- LibPQ.resultErrorMessage result
649+ throw $ SquealException status stateCode msg
squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+22−1
@@ -41,7 +41,28 @@ import Generics.SOP (K(..))
4141import Squeal.PostgreSQL.PQ
4242import Squeal.PostgreSQL.Schema
4343
44−-- | `PoolPQ` @schema@ should be a drop-in replacement for `PQ` @schema schema@.
44+{- | `PoolPQ` @schema@ should be a drop-in replacement for `PQ` @schema schema@.
45+
46+Typical use case would be to create your pool using `createConnectionPool` and run anything that requires the pool connection with it.
47+
48+Here's a simplified example:
49+
50+> type Schema = '[ "tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint2])]
51+>
52+> someQuery :: Manipulation Schema '[ 'NotNull 'PGint2] '[]
53+> someQuery = insertRow #tab
54+> (Set (param @1) `As` #col :* Nil)
55+> OnConflictDoNothing (Returning Nil)
56+>
57+> insertOne :: (MonadBaseControl IO m, MonadPQ Schema m) => m ()
58+> insertOne = void $ manipulateParams someQuery . Only $ (1 :: Int16)
59+>
60+> insertOneInPool :: ByteString -> IO ()
61+> insertOneInPool connectionString = do
62+> pool <- createConnectionPool connectionString 1 0.5 10
63+> liftIO $ runPoolPQ (insertOne) pool
64+
65+-}
4566newtype PoolPQ (schema :: SchemaType) m x =
4667 PoolPQ { runPoolPQ :: Pool (K Connection schema) -> m x }
4768 deriving Functor
squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+202−2
@@ -9,7 +9,8 @@ Squeal queries.
99-}
1010
1111{-# LANGUAGE
12− DeriveGeneric
12+ ConstraintKinds
13+ , DeriveGeneric
1314 , FlexibleContexts
1415 , FlexibleInstances
1516 , GADTs
@@ -21,8 +22,9 @@ Squeal queries.
2122 , TypeFamilies
2223 , TypeInType
2324 , TypeOperators
25+ , RankNTypes
2426 , UndecidableInstances
25−#-}
27+ #-}
2628
2729module Squeal.PostgreSQL.Query
2830 ( -- * Queries
@@ -52,6 +54,21 @@ module Squeal.PostgreSQL.Query
5254 , orderBy
5355 , limit
5456 , offset
57+ -- ** JSON table expressions
58+ , PGjson_each
59+ , PGjsonb_each
60+ , jsonEach
61+ , jsonbEach
62+ , jsonEachAsText
63+ , jsonbEachAsText
64+ , jsonPopulateRecordAs
65+ , jsonbPopulateRecordAs
66+ , jsonPopulateRecordSetAs
67+ , jsonbPopulateRecordSetAs
68+ , jsonToRecordAs
69+ , jsonbToRecordAs
70+ , jsonToRecordSetAs
71+ , jsonbToRecordSetAs
5572 -- * From
5673 , FromClause (..)
5774 , table
@@ -627,6 +644,189 @@ offset
627644 -> TableExpression schema params relations grouping
628645offset off rels = rels {offsetClause = off : offsetClause rels}
629646
647+{-----------------------------------------
648+JSON stuff
649+-----------------------------------------}
650+
651+type PGjson_each_variant val tab =
652+ '[ tab ::: '[ "key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull val ] ]
653+
654+-- | The type of a `json_each` `FromClause`.
655+type PGjson_each tab = PGjson_each_variant 'PGjson tab
656+-- | The type of a `jsonb_each` `FromClause`.
657+type PGjsonb_each tab = PGjson_each_variant 'PGjsonb tab
658+-- | The type of a `json_each_text` `FromClause`.
659+type PGjson_each_text tab = PGjson_each_variant 'PGtext tab
660+-- | The type of a `jsonb_each_text` `FromClause`.
661+type PGjsonb_each_text tab = PGjson_each_variant 'PGtext tab
662+
663+unsafeAliasedFromClauseExpression
664+ :: Aliased (Expression schema' relations' grouping' params') ty'
665+ -> FromClause schema params relations
666+unsafeAliasedFromClauseExpression aliasedExpr = UnsafeFromClause
667+ (renderAliasedAs renderExpression aliasedExpr)
668+
669+-- | Expands the outermost JSON object into a set of key/value pairs.
670+jsonEach
671+ :: Aliased (Expression schema '[] 'Ungrouped params) '(tab, nullity 'PGjson)
672+ -> FromClause schema params (PGjson_each tab)
673+jsonEach (As jexpr jname) = unsafeAliasedFromClauseExpression
674+ (As (unsafeFunction "json_each" jexpr) jname)
675+
676+-- | Expands the outermost binary JSON object into a set of key/value pairs.
677+jsonbEach
678+ :: Aliased (Expression schema '[] 'Ungrouped params) '(tab, nullity 'PGjsonb)
679+ -> FromClause schema params (PGjsonb_each tab)
680+jsonbEach (As jexpr jname) = unsafeAliasedFromClauseExpression
681+ (As (unsafeFunction "jsonb_each" jexpr) jname)
682+
683+-- | Expands the outermost JSON object into a set of key/value pairs.
684+jsonEachAsText
685+ :: Aliased (Expression schema '[] 'Ungrouped params) '(tab, nullity 'PGjson)
686+ -> FromClause schema params (PGjson_each_text tab)
687+jsonEachAsText (As jexpr jname) = unsafeAliasedFromClauseExpression
688+ (As (unsafeFunction "json_each" jexpr) jname)
689+
690+-- | Expands the outermost binary JSON object into a set of key/value pairs.
691+jsonbEachAsText
692+ :: Aliased (Expression schema '[] 'Ungrouped params) '(tab, nullity 'PGjsonb)
693+ -> FromClause schema params (PGjsonb_each_text tab)
694+jsonbEachAsText (As jexpr jname) = unsafeAliasedFromClauseExpression
695+ (As (unsafeFunction "jsonb_each" jexpr) jname)
696+
697+nullRow
698+ :: Has tab schema ('Table table)
699+ => Alias tab
700+ -> Expression schema relations grouping params
701+ (nullity ('PGcomposite (TableToRelation table)))
702+nullRow tab = UnsafeExpression ("null::"<+>renderAlias tab)
703+
704+-- | Expands the JSON expression to a row whose columns match the record
705+-- type defined by the given table.
706+jsonPopulateRecordAs
707+ :: (KnownSymbol alias, Has tab schema ('Table table))
708+ => Alias tab
709+ -> Expression schema '[] 'Ungrouped params (nullity 'PGjson)
710+ -> Alias alias
711+ -> FromClause schema params '[alias ::: TableToRelation table]
712+jsonPopulateRecordAs tableName expr alias = unsafeAliasedFromClauseExpression
713+ (unsafeVariadicFunction "json_populate_record"
714+ (nullRow tableName :* expr :* Nil) `As` alias)
715+
716+-- | Expands the binary JSON expression to a row whose columns match the record
717+-- type defined by the given table.
718+jsonbPopulateRecordAs
719+ :: (KnownSymbol alias, Has tab schema ('Table table))
720+ => Alias tab
721+ -> Expression schema '[] 'Ungrouped params (nullity 'PGjsonb)
722+ -> Alias alias
723+ -> FromClause schema params '[alias ::: TableToRelation table]
724+jsonbPopulateRecordAs tableName expr alias = unsafeAliasedFromClauseExpression
725+ (unsafeVariadicFunction "jsonb_populate_record"
726+ (nullRow tableName :* expr :* Nil) `As` alias)
727+
728+-- | Expands the outermost array of objects in the given JSON expression to a
729+-- set of rows whose columns match the record type defined by the given table.
730+jsonPopulateRecordSetAs
731+ :: (KnownSymbol alias, Has tab schema ('Table table))
732+ => Alias tab
733+ -> Expression schema '[] 'Ungrouped params (nullity 'PGjson)
734+ -> Alias alias
735+ -> FromClause schema params '[alias ::: TableToRelation table]
736+jsonPopulateRecordSetAs tableName expr alias = unsafeAliasedFromClauseExpression
737+ (unsafeVariadicFunction "json_populate_record_set"
738+ (nullRow tableName :* expr :* Nil) `As` alias)
739+
740+-- | Expands the outermost array of objects in the given binary JSON expression
741+-- to a set of rows whose columns match the record type defined by the given
742+-- table.
743+jsonbPopulateRecordSetAs
744+ :: (KnownSymbol alias, Has tab schema ('Table table))
745+ => Alias tab
746+ -> Expression schema '[] 'Ungrouped params (nullity 'PGjsonb)
747+ -> Alias alias
748+ -> FromClause schema params '[alias ::: TableToRelation table]
749+jsonbPopulateRecordSetAs tableName expr alias = unsafeAliasedFromClauseExpression
750+ (unsafeVariadicFunction "jsonb_populate_record_set"
751+ (nullRow tableName :* expr :* Nil) `As` alias)
752+
753+renderTableTypeExpression
754+ :: All Top types
755+ => Aliased (NP (Aliased (TypeExpression schema))) (tab ::: types)
756+ -> ByteString
757+renderTableTypeExpression (hc `As` tab)
758+ = (renderAlias tab <>)
759+ . parenthesized
760+ . commaSeparated
761+ . flip appEndo []
762+ . hcfoldMap
763+ (Proxy :: Proxy Top)
764+ (\(ty `As` name) -> Endo
765+ ((renderAlias name <+> renderTypeExpression ty):))
766+ $ hc
767+
768+unsafeTableAliasedFromClauseExpression
769+ :: All Top types
770+ => Expression schema' relations' grouping' params' ty'
771+ -> Aliased (NP (Aliased (TypeExpression schema))) (tab ::: types)
772+ -> FromClause schema params '[alias ::: types]
773+unsafeTableAliasedFromClauseExpression expr types = UnsafeFromClause
774+ (renderExpression expr
775+ <+> "AS"
776+ <+> renderTableTypeExpression types)
777+
778+-- | Builds an arbitrary record from a JSON object. As with all functions
779+-- returning record, the caller must explicitly define the structure of the
780+-- record with an AS clause.
781+jsonToRecordAs
782+ :: All Top types
783+ => Expression schema '[] 'Ungrouped params (nullity 'PGjson)
784+ -> Aliased (NP (Aliased (TypeExpression schema))) (tab ::: types)
785+ -> FromClause schema params '[tab ::: types]
786+jsonToRecordAs expr types =
787+ unsafeTableAliasedFromClauseExpression
788+ (unsafeFunction "json_to_record" expr)
789+ types
790+
791+-- | Builds an arbitrary record from a binary JSON object. As with all functions
792+-- returning record, the caller must explicitly define the structure of the
793+-- record with an AS clause.
794+jsonbToRecordAs
795+ :: All Top types
796+ => Expression schema '[] 'Ungrouped params (nullity 'PGjsonb)
797+ -> Aliased (NP (Aliased (TypeExpression schema))) (tab ::: types)
798+ -> FromClause schema params '[tab ::: types]
799+jsonbToRecordAs expr types =
800+ unsafeTableAliasedFromClauseExpression
801+ (unsafeFunction "jsonb_to_record" expr)
802+ types
803+
804+-- | Builds an arbitrary set of records from a JSON array of objects (see note
805+-- below). As with all functions returning record, the caller must explicitly
806+-- define the structure of the record with an AS clause.
807+jsonToRecordSetAs
808+ :: All Top types
809+ => Expression schema '[] 'Ungrouped params (nullity 'PGjson)
810+ -> Aliased (NP (Aliased (TypeExpression schema))) (tab ::: types)
811+ -> FromClause schema params '[tab ::: types]
812+jsonToRecordSetAs expr types =
813+ unsafeTableAliasedFromClauseExpression
814+ (unsafeFunction "json_to_recordset" expr)
815+ types
816+
817+-- | Builds an arbitrary set of records from a binary JSON array of objects (see
818+-- note below). As with all functions returning record, the caller must
819+-- explicitly define the structure of the record with an AS clause.
820+jsonbToRecordSetAs
821+ :: All Top types
822+ => Expression schema '[] 'Ungrouped params (nullity 'PGjsonb)
823+ -> Aliased (NP (Aliased (TypeExpression schema))) (tab ::: types)
824+ -> FromClause schema params '[tab ::: types]
825+jsonbToRecordSetAs expr types =
826+ unsafeTableAliasedFromClauseExpression
827+ (unsafeFunction "jsonb_to_recordset" expr)
828+ types
829+
630830{-----------------------------------------
631831FROM clauses
632832-----------------------------------------}
squeal-postgresql/src/Squeal/PostgreSQL/Render.hs+13−1
@@ -25,6 +25,8 @@ module Squeal.PostgreSQL.Render
2525 , (<+>)
2626 , commaSeparated
2727 , doubleQuoted
28+ , singleQuotedText
29+ , singleQuotedUtf8
2830 , renderCommaSeparated
2931 , renderCommaSeparatedMaybe
3032 , renderNat
@@ -37,10 +39,12 @@ import Control.Monad.Base
3739import Data.ByteString (ByteString)
3840import Data.Maybe
3941import Data.Monoid ((<>))
42+import Data.Text (Text)
4043import Generics.SOP
4144import GHC.Exts
4245import GHC.TypeLits
43−
46+import qualified Data.Text as T
47+import qualified Data.Text.Encoding as T
4448import qualified Data.ByteString as ByteString
4549import qualified Data.ByteString.Char8 as Char8
4650
@@ -60,6 +64,14 @@ commaSeparated = ByteString.intercalate ", "
6064doubleQuoted :: ByteString -> ByteString
6165doubleQuoted str = "\"" <> str <> "\""
6266
67+-- | Add single quotes around a `Text` and escape single quotes within it.
68+singleQuotedText :: Text -> ByteString
69+singleQuotedText str = "'" <> T.encodeUtf8 (T.replace "'" "''" str) <> "'"
70+
71+-- | Add single quotes around a `ByteString` and escape single quotes within it.
72+singleQuotedUtf8 :: ByteString -> ByteString
73+singleQuotedUtf8 = singleQuotedText . T.decodeUtf8
74+
6375-- | Comma separate the renderings of a heterogeneous list.
6476renderCommaSeparated
6577 :: SListI xs
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+61−1
@@ -10,7 +10,7 @@ tables, schema, constraints, aliases, enumerated labels, and groupings.
1010It also defines useful type families to operate on these. Finally,
1111it defines an embedding of Haskell types into Postgres types.
1212-}
13−
13+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
1414{-# LANGUAGE
1515 AllowAmbiguousTypes
1616 , ConstraintKinds
@@ -68,6 +68,7 @@ module Squeal.PostgreSQL.Schema
6868 , HasAll
6969 , IsLabel (..)
7070 , IsQualified (..)
71+ , renderAliasString
7172 -- * Enumerated Labels
7273 , IsPGlabel (..)
7374 , PGlabel (..)
@@ -89,6 +90,10 @@ module Squeal.PostgreSQL.Schema
8990 , PGNum
9091 , PGIntegral
9192 , PGFloating
93+ , PGTypeOf
94+ , PGarrayOf
95+ , PGarray
96+ , PGtextArray
9297 , SameTypes
9398 , SamePGType
9499 , AllNotNull
@@ -99,8 +104,12 @@ module Squeal.PostgreSQL.Schema
99104 , ColumnsToRelation
100105 , TableToColumns
101106 , TableToRelation
107+ , RelationToNullityTypes
102108 , ConstraintInvolves
103109 , DropIfConstraintsInvolve
110+ -- ** JSON support
111+ , PGjson_
112+ , PGjsonKey
104113 -- * Embedding
105114 , PG
106115 , EnumFrom
@@ -364,6 +373,11 @@ instance KnownSymbol alias => RenderSQL (Alias alias) where renderSQL = renderAl
364373renderAlias :: KnownSymbol alias => Alias alias -> ByteString
365374renderAlias = doubleQuoted . fromString . symbolVal
366375
376+-- | >>> renderAliasString #ohmahgerd
377+-- "'ohmahgerd'"
378+renderAliasString :: KnownSymbol alias => Alias alias -> ByteString
379+renderAliasString = singleQuotedText . fromString . symbolVal
380+
367381-- | >>> import Generics.SOP (NP(..))
368382-- >>> renderAliases (#jimbob :* #kandi)
369383-- ["\"jimbob\"","\"kandi\""]
@@ -487,6 +501,41 @@ type PGFloating ty = In ty '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]
487501-- `Squeal.PostgreSQL.Expression.mod_` functions.
488502type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]
489503
504+-- | Error message helper for displaying unavailable\/unknown\/placeholder type
505+-- variables whose kind is known.
506+type Placeholder k = 'Text "(_::" :<>: 'ShowType k :<>: 'Text ")"
507+
508+type ErrArrayOf arr ty = arr :<>: 'Text " " :<>: ty
509+type ErrPGfixarrayOf t = ErrArrayOf ('ShowType 'PGfixarray :<>: 'Text " " :<>: Placeholder Nat) t
510+type ErrPGvararrayOf t = ErrArrayOf ('ShowType 'PGvararray) t
511+
512+-- | Ensure a type is a valid array type.
513+type family PGarray name arr :: Constraint where
514+ PGarray name ('PGvararray x) = ()
515+ PGarray name ('PGfixarray n x) = ()
516+ PGarray name val = TypeError
517+ ('Text name :<>: 'Text ": Unsatisfied PGarray constraint. Expected either: "
518+ :$$: 'Text " • " :<>: ErrPGvararrayOf (Placeholder PGType)
519+ :$$: 'Text " • " :<>: ErrPGfixarrayOf (Placeholder PGType)
520+ :$$: 'Text "But got: " :<>: 'ShowType val)
521+
522+-- | Ensure a type is a valid array type with a specific element type.
523+type family PGarrayOf name arr ty :: Constraint where
524+ PGarrayOf name ('PGvararray x) ty = x ~ ty
525+ PGarrayOf name ('PGfixarray n x) ty = x ~ ty
526+ PGarrayOf name val ty = TypeError
527+ ( 'Text name :<>: 'Text "Unsatisfied PGarrayOf constraint. Expected either: "
528+ :$$: 'Text " • " :<>: ErrPGvararrayOf ( 'ShowType ty )
529+ :$$: 'Text " • " :<>: ErrPGfixarrayOf ( 'ShowType ty )
530+ :$$: 'Text "But got: " :<>: 'ShowType val)
531+
532+-- | Ensure a type is a valid array type whose elements are text.
533+type PGtextArray name arr = PGarrayOf name arr ('NotNull 'PGtext)
534+
535+-- | `PGTypeOf` forgets about @NULL@ and any column constraints.
536+type family PGTypeOf (ty :: NullityType) :: PGType where
537+ PGTypeOf (nullity pg) = pg
538+
490539-- | `SameTypes` is a constraint that proves two `ColumnsType`s have the same
491540-- length and the same `ColumnType`s.
492541type family SameTypes (columns0 :: ColumnsType) (columns1 :: ColumnsType)
@@ -532,6 +581,11 @@ type family NullifyRelations (tables :: RelationsType) :: RelationsType where
532581 NullifyRelations (table ::: columns ': tables) =
533582 table ::: NullifyRelation columns ': NullifyRelations tables
534583
584+-- | `RelationToNullityTypes` drops the column constraints.
585+type family RelationToNullityTypes (rel :: RelationType) :: [NullityType] where
586+ RelationToNullityTypes ('(k, x) : xs) = x : RelationToNullityTypes xs
587+ RelationToNullityTypes '[] = '[]
588+
535589-- | `Join` is simply promoted `++` and is used in @JOIN@s in
536590-- `Squeal.PostgreSQL.Query.FromClause`s.
537591type family Join xs ys where
@@ -744,3 +798,9 @@ type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])
744798 ConstructorNamesOf '[] = '[]
745799 ConstructorNamesOf (constructor ': constructors) =
746800 ConstructorNameOf constructor ': ConstructorNamesOf constructors
801+
802+-- | Is a type a valid JSON key?
803+type PGjsonKey key = key `In` '[ 'PGint2, 'PGint4, 'PGtext ]
804+
805+-- | Is a type a valid JSON type?
806+type PGjson_ json = json `In` '[ 'PGjson, 'PGjsonb ]
squeal-postgresql/test/Specs/ExceptionHandling.hsnew file+118
@@ -0,0 +1,118 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DuplicateRecordFields #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE OverloadedLabels #-}
6+{-# LANGUAGE OverloadedLists #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+module ExceptionHandling
12+ (
13+ specs
14+ )
15+where
16+
17+import Control.Monad (void)
18+import Control.Monad.Base (MonadBase)
19+import qualified Data.ByteString.Char8 as Char8
20+import Data.Int (Int16)
21+import Data.Text (Text)
22+import Data.Vector (Vector)
23+import qualified Generics.SOP as SOP
24+import qualified GHC.Generics as GHC
25+import Squeal.PostgreSQL
26+import Squeal.PostgreSQL.Migration
27+import Test.Hspec
28+
29+type Schema =
30+ '[ "users" ::: 'Table (
31+ '[ "pk_users" ::: 'PrimaryKey '["id"]
32+ , "unique_names" ::: 'Unique '["name"]
33+ ] :=>
34+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
35+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
36+ , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2))
37+ ])
38+ , "emails" ::: 'Table (
39+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
40+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
41+ ] :=>
42+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
43+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
44+ , "email" ::: 'NoDef :=> 'Null 'PGtext
45+ ])
46+ ]
47+
48+data User =
49+ User { userName :: Text
50+ , userEmail :: Maybe Text
51+ , userVec :: Vector (Maybe Int16) }
52+ deriving (Show, GHC.Generic)
53+instance SOP.Generic User
54+instance SOP.HasDatatypeInfo User
55+
56+insertUser :: Manipulation Schema '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]
57+ '[ "fromOnly" ::: 'NotNull 'PGint4 ]
58+insertUser = insertRows #users
59+ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec) []
60+ OnConflictDoRaise (Returning (#id `as` #fromOnly))
61+
62+setup :: Definition '[] Schema
63+setup =
64+ createTable #users
65+ ( serial `as` #id :*
66+ (text & notNullable) `as` #name :*
67+ (vararray int2 & notNullable) `as` #vec )
68+ ( primaryKey #id `as` #pk_users
69+ :* unique #name `as` #unique_names )
70+ >>>
71+ createTable #emails
72+ ( serial `as` #id :*
73+ (int & notNullable) `as` #user_id :*
74+ (text & nullable) `as` #email )
75+ ( primaryKey #id `as` #pk_emails :*
76+ foreignKey #user_id #users #id
77+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
78+
79+teardown :: Definition Schema '[]
80+teardown = dropTable #emails >>> dropTable #users
81+
82+migration :: Migration IO '[] Schema
83+migration = Migration { name = "test"
84+ , up = void $ define setup
85+ , down = void $ define teardown }
86+
87+setupDB :: IO ()
88+setupDB = void . withConnection connectionString $
89+ manipulate (UnsafeManipulation "SET client_min_messages = warning;")
90+ & pqThen $ migrateUp $ single migration
91+
92+dropDB :: IO ()
93+dropDB = void . withConnection connectionString $
94+ manipulate (UnsafeManipulation "SET client_min_messages = warning;")
95+ & pqThen $ migrateDown $ single migration
96+
97+connectionString :: Char8.ByteString
98+connectionString = "host=localhost port=5432 dbname=exampledb"
99+
100+testUser :: User
101+testUser = User "TestUser" Nothing []
102+
103+newUser :: (MonadBase IO m, MonadPQ Schema m) => User -> m ()
104+newUser u = void $ manipulateParams insertUser (userName u, userVec u)
105+
106+insertUserTwice :: (MonadBase IO m, MonadPQ Schema m) => m ()
107+insertUserTwice = newUser testUser >> newUser testUser
108+
109+specs :: SpecWith ()
110+specs = before_ setupDB $ after_ dropDB $
111+ describe "Exceptions" $ do
112+ it "Should be raised in transactions and cause rollback" $
113+ withConnection connectionString insertUserTwice
114+ `shouldThrow` (const True :: Selector SquealException)
115+
116+ it "Should be raised outside of transactions" $
117+ withConnection connectionString (transactionally_ insertUserTwice)
118+ `shouldThrow` (const True :: Selector SquealException)
squeal-postgresql/test/Specs/Specs.hsnew file+7
@@ -0,0 +1,7 @@
1+module Specs where
2+
3+import Test.Hspec
4+import qualified ExceptionHandling
5+
6+main :: IO ()
7+main = hspec ExceptionHandling.specs