b259049 · squeal · git.iko.soy

git.iko.soy/squeal

on dev help sign in

Merge branch '0.4-exceptions' into 0.4-array+exceptions

b259049Eitan Chatav8 years ago

RELEASE NOTES.md+10

compare with dev

unifiedsplit

@@ -1,5 +1,15 @@

1## RELEASE NOTES

3+### Version 0.3.2 - August 4, 2018

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+

3### Version 0.3.1 - July 7, 2018

13### Version 0.3.1 - July 7, 2018

5Version 0.3.1 of Squeal enables the "Scrap your Nils" trick for

15Version 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

71 base >= 4.10.0.0

72 , doctest >= 0.11.4

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+

74executable squeal-postgresql-example

92executable squeal-postgresql-example

75 default-language: Haskell2010

93 default-language: Haskell2010

76 hs-source-dirs: exe

94 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.

11{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

12{-# LANGUAGE

13 AllowAmbiguousTypes

14+ , ConstraintKinds

14 , DeriveGeneric

15 , DeriveGeneric

15 , FlexibleContexts

16 , FlexibleContexts

16 , FlexibleInstances

17 , FlexibleInstances

@@ -25,6 +26,7 @@ Squeal expressions are the atoms used to build statements.

25 , TypeInType

26 , TypeInType

26 , TypeOperators

27 , TypeOperators

27 , UndecidableInstances

28 , UndecidableInstances

29+ , RankNTypes

28#-}

30#-}

30module Squeal.PostgreSQL.Expression

32module Squeal.PostgreSQL.Expression

@@ -48,6 +50,7 @@ module Squeal.PostgreSQL.Expression

48 , unsafeBinaryOp

50 , unsafeBinaryOp

49 , unsafeUnaryOp

51 , unsafeUnaryOp

50 , unsafeFunction

52 , unsafeFunction

53+ , unsafeVariadicFunction

51 , atan2_

54 , atan2_

52 , cast

55 , cast

53 , quot_

56 , quot_

@@ -83,6 +86,53 @@ module Squeal.PostgreSQL.Expression

83 , upper

86 , upper

84 , charLength

87 , charLength

85 , like

88 , 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

86 -- ** Aggregation

136 -- ** Aggregation

87 , unsafeAggregate, unsafeAggregateDistinct

137 , unsafeAggregate, unsafeAggregateDistinct

88 , sum_, sumDistinct

138 , sum_, sumDistinct

@@ -135,8 +185,10 @@ module Squeal.PostgreSQL.Expression

135import Control.Category

185import Control.Category

136import Control.DeepSeq

186import Control.DeepSeq

137import Data.ByteString (ByteString)

187import Data.ByteString (ByteString)

188+import Data.ByteString.Lazy (toStrict)

138import Data.Function ((&))

189import Data.Function ((&))

139−import Data.Semigroup

190+import Data.Semigroup hiding (All)

191+import qualified Data.Aeson as JSON

140import Data.Ratio

192import Data.Ratio

141import Data.String

193import Data.String

142import Generics.SOP hiding (from)

194import Generics.SOP hiding (from)

@@ -482,6 +534,16 @@ unsafeFunction

482unsafeFunction fun x = UnsafeExpression $

534unsafeFunction fun x = UnsafeExpression $

483 fun <> parenthesized (renderExpression x)

535 fun <> parenthesized (renderExpression x)

484

536

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+

485instance PGNum ty

547instance PGNum ty

486 => Num (Expression schema relations grouping params (nullity ty)) where

548 => Num (Expression schema relations grouping params (nullity ty)) where

487 (+) = unsafeBinaryOp "+"

549 (+) = unsafeBinaryOp "+"

@@ -870,6 +932,400 @@ like

870 -> Expression schema relations grouping params (nullity 'PGbool)

932 -> Expression schema relations grouping params (nullity 'PGbool)

871like = unsafeBinaryOp "LIKE"

933like = unsafeBinaryOp "LIKE"

872

934

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+

873{-----------------------------------------

1329{-----------------------------------------

874aggregation

1330aggregation

875-----------------------------------------}

1331-----------------------------------------}

squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+46−19

@@ -62,6 +62,8 @@ module Squeal.PostgreSQL.PQ

62 , LibPQ.ExecStatus (..)

63 , resultStatus

64 , resultErrorMessage

65+ , resultErrorCode

66+ , SquealException (..)

65 ) where

67 ) where

67import Control.Exception.Lifted

69import Control.Exception.Lifted

@@ -403,7 +405,9 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)

403 case resultMaybe of

405 case resultMaybe of

404 Nothing -> error

406 Nothing -> error

405 "manipulateParams: LibPQ.execParams returned no results"

407 "manipulateParams: LibPQ.execParams returned no results"

408+ Just result -> do

409+ tryResult result

406− Just result -> return $ K (K result)

410+ return $ K (K result)

407

411

408 traversePrepared

412 traversePrepared

409 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =

413 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =

@@ -413,10 +417,7 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)

413 case prepResultMaybe of

417 case prepResultMaybe of

414 Nothing -> error

418 Nothing -> error

415 "traversePrepared: LibPQ.prepare returned no results"

419 "traversePrepared: LibPQ.prepare returned no results"

416− Just prepResult -> do

420+ Just prepResult -> tryResult prepResult

417− status <- LibPQ.resultStatus prepResult

418− unless (status == LibPQ.CommandOk) . error $

419− "traversePrepared: LibPQ.prepare status " <> show status

420 results <- for list $ \ params -> do

421 results <- for list $ \ params -> do

421 let

422 let

422 toParam' encoding = (encodingBytes encoding,LibPQ.Binary)

423 toParam' encoding = (encodingBytes encoding,LibPQ.Binary)

@@ -425,15 +426,14 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)

425 case resultMaybe of

426 case resultMaybe of

426 Nothing -> error

427 Nothing -> error

427 "traversePrepared: LibPQ.execParams returned no results"

428 "traversePrepared: LibPQ.execParams returned no results"

429+ Just result -> do

430+ tryResult result

428− Just result -> return $ K result

431+ return $ K result

429 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

432 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

430 case deallocResultMaybe of

433 case deallocResultMaybe of

431 Nothing -> error

434 Nothing -> error

432 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"

435 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"

433− Just deallocResult -> do

436+ Just deallocResult -> tryResult deallocResult

434− status <- LibPQ.resultStatus deallocResult

435− unless (status == LibPQ.CommandOk) . error $

436− "traversePrepared: DEALLOCATE status " <> show status

437 return (K results)

438

439 traversePrepared_

@@ -444,10 +444,7 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)

444 case prepResultMaybe of

445 Nothing -> error

446 "traversePrepared_: LibPQ.prepare returned no results"

447− Just prepResult -> do

447+ Just prepResult -> tryResult prepResult

448− status <- LibPQ.resultStatus prepResult

449− unless (status == LibPQ.CommandOk) . error $

450− "traversePrepared: LibPQ.prepare status " <> show status

451 for_ list $ \ params -> do

448 for_ list $ \ params -> do

452 let

449 let

453 toParam' encoding = (encodingBytes encoding, LibPQ.Binary)

450 toParam' encoding = (encodingBytes encoding, LibPQ.Binary)

@@ -456,15 +453,12 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)

456 case resultMaybe of

453 case resultMaybe of

457 Nothing -> error

454 Nothing -> error

458 "traversePrepared_: LibPQ.execParams returned no results"

455 "traversePrepared_: LibPQ.execParams returned no results"

459− Just _result -> return ()

456+ Just result -> tryResult result

460 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

457 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

461 case deallocResultMaybe of

458 case deallocResultMaybe of

462 Nothing -> error

459 Nothing -> error

463 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"

460 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"

464− Just deallocResult -> do

461+ Just deallocResult -> tryResult deallocResult

465− status <- LibPQ.resultStatus deallocResult

466− unless (status == LibPQ.CommandOk) . error $

467− "traversePrepared: DEALLOCATE status " <> show status

468 return (K ())

462 return (K ())

469

463

470 liftPQ pq = PQ $ \ (K conn) -> do

464 liftPQ pq = PQ $ \ (K conn) -> do

@@ -620,3 +614,36 @@ resultStatus = liftResult LibPQ.resultStatus

620resultErrorMessage

614resultErrorMessage

621 :: MonadBase IO io => K LibPQ.Result results -> io (Maybe ByteString)

615 :: MonadBase IO io => K LibPQ.Result results -> io (Maybe ByteString)

622resultErrorMessage = liftResult LibPQ.resultErrorMessage

616resultErrorMessage = 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(..))

41import Squeal.PostgreSQL.PQ

42import Squeal.PostgreSQL.Schema

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+-}

45newtype PoolPQ (schema :: SchemaType) m x =

66newtype PoolPQ (schema :: SchemaType) m x =

46 PoolPQ { runPoolPQ :: Pool (K Connection schema) -> m x }

67 PoolPQ { runPoolPQ :: Pool (K Connection schema) -> m x }

47 deriving Functor

68 deriving Functor

squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+202−2

@@ -9,7 +9,8 @@ Squeal queries.

9-}

11{-# LANGUAGE

12+ ConstraintKinds

12− DeriveGeneric

13+ , DeriveGeneric

13 , FlexibleContexts

14 , FlexibleContexts

14 , FlexibleInstances

15 , FlexibleInstances

15 , GADTs

16 , GADTs

@@ -21,8 +22,9 @@ Squeal queries.

21 , TypeFamilies

22 , TypeFamilies

22 , TypeInType

23 , TypeInType

23 , TypeOperators

24 , TypeOperators

25+ , RankNTypes

24 , UndecidableInstances

26 , UndecidableInstances

25−#-}

27+ #-}

27module Squeal.PostgreSQL.Query

29module Squeal.PostgreSQL.Query

28 ( -- * Queries

30 ( -- * Queries

@@ -52,6 +54,21 @@ module Squeal.PostgreSQL.Query

52 , orderBy

54 , orderBy

53 , limit

55 , limit

54 , offset

56 , 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

55 -- * From

72 -- * From

56 , FromClause (..)

73 , FromClause (..)

57 , table

74 , table

@@ -627,6 +644,189 @@ offset

627 -> TableExpression schema params relations grouping

644 -> TableExpression schema params relations grouping

628offset off rels = rels {offsetClause = off : offsetClause rels}

645offset off rels = rels {offsetClause = off : offsetClause rels}

629

646

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+

630{-----------------------------------------

830{-----------------------------------------

631FROM clauses

831FROM clauses

632-----------------------------------------}

832-----------------------------------------}

squeal-postgresql/src/Squeal/PostgreSQL/Render.hs+13−1

@@ -25,6 +25,8 @@ module Squeal.PostgreSQL.Render

25 , (<+>)

26 , commaSeparated

27 , doubleQuoted

28+ , singleQuotedText

29+ , singleQuotedUtf8

28 , renderCommaSeparated

30 , renderCommaSeparated

29 , renderCommaSeparatedMaybe

31 , renderCommaSeparatedMaybe

30 , renderNat

32 , renderNat

@@ -37,10 +39,12 @@ import Control.Monad.Base

37import Data.ByteString (ByteString)

39import Data.ByteString (ByteString)

38import Data.Maybe

40import Data.Maybe

39import Data.Monoid ((<>))

41import Data.Monoid ((<>))

42+import Data.Text (Text)

40import Generics.SOP

43import Generics.SOP

41import GHC.Exts

44import GHC.Exts

42import GHC.TypeLits

45import GHC.TypeLits

43−

46+import qualified Data.Text as T

47+import qualified Data.Text.Encoding as T

44import qualified Data.ByteString as ByteString

48import qualified Data.ByteString as ByteString

45import qualified Data.ByteString.Char8 as Char8

49import qualified Data.ByteString.Char8 as Char8

@@ -60,6 +64,14 @@ commaSeparated = ByteString.intercalate ", "

60doubleQuoted :: ByteString -> ByteString

64doubleQuoted :: ByteString -> ByteString

61doubleQuoted str = "\"" <> str <> "\""

65doubleQuoted str = "\"" <> str <> "\""

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+

63-- | Comma separate the renderings of a heterogeneous list.

75-- | Comma separate the renderings of a heterogeneous list.

64renderCommaSeparated

76renderCommaSeparated

65 :: SListI xs

77 :: SListI xs

squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+61−1

@@ -10,7 +10,7 @@ tables, schema, constraints, aliases, enumerated labels, and groupings.

10It also defines useful type families to operate on these. Finally,

11it defines an embedding of Haskell types into Postgres types.

12-}

13−

13+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}

14{-# LANGUAGE

15 AllowAmbiguousTypes

16 , ConstraintKinds

@@ -68,6 +68,7 @@ module Squeal.PostgreSQL.Schema

68 , HasAll

69 , IsLabel (..)

70 , IsQualified (..)

71+ , renderAliasString

71 -- * Enumerated Labels

72 -- * Enumerated Labels

72 , IsPGlabel (..)

73 , IsPGlabel (..)

73 , PGlabel (..)

74 , PGlabel (..)

@@ -89,6 +90,10 @@ module Squeal.PostgreSQL.Schema

89 , PGNum

90 , PGNum

90 , PGIntegral

91 , PGIntegral

91 , PGFloating

92 , PGFloating

93+ , PGTypeOf

94+ , PGarrayOf

95+ , PGarray

96+ , PGtextArray

92 , SameTypes

97 , SameTypes

93 , SamePGType

98 , SamePGType

94 , AllNotNull

99 , AllNotNull

@@ -99,8 +104,12 @@ module Squeal.PostgreSQL.Schema

99 , ColumnsToRelation

104 , ColumnsToRelation

100 , TableToColumns

105 , TableToColumns

101 , TableToRelation

106 , TableToRelation

107+ , RelationToNullityTypes

102 , ConstraintInvolves

108 , ConstraintInvolves

103 , DropIfConstraintsInvolve

109 , DropIfConstraintsInvolve

110+ -- ** JSON support

111+ , PGjson_

112+ , PGjsonKey

104 -- * Embedding

113 -- * Embedding

105 , PG

114 , PG

106 , EnumFrom

115 , EnumFrom

@@ -364,6 +373,11 @@ instance KnownSymbol alias => RenderSQL (Alias alias) where renderSQL = renderAl

364renderAlias :: KnownSymbol alias => Alias alias -> ByteString

373renderAlias :: KnownSymbol alias => Alias alias -> ByteString

365renderAlias = doubleQuoted . fromString . symbolVal

374renderAlias = doubleQuoted . fromString . symbolVal

366

375

376+-- | >>> renderAliasString #ohmahgerd

377+-- "'ohmahgerd'"

378+renderAliasString :: KnownSymbol alias => Alias alias -> ByteString

379+renderAliasString = singleQuotedText . fromString . symbolVal

380+

367-- | >>> import Generics.SOP (NP(..))

381-- | >>> import Generics.SOP (NP(..))

368-- >>> renderAliases (#jimbob :* #kandi)

382-- >>> renderAliases (#jimbob :* #kandi)

369-- ["\"jimbob\"","\"kandi\""]

383-- ["\"jimbob\"","\"kandi\""]

@@ -487,6 +501,41 @@ type PGFloating ty = In ty '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]

487-- `Squeal.PostgreSQL.Expression.mod_` functions.

501-- `Squeal.PostgreSQL.Expression.mod_` functions.

488type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]

502type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]

489

503

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+

490-- | `SameTypes` is a constraint that proves two `ColumnsType`s have the same

539-- | `SameTypes` is a constraint that proves two `ColumnsType`s have the same

491-- length and the same `ColumnType`s.

540-- length and the same `ColumnType`s.

492type family SameTypes (columns0 :: ColumnsType) (columns1 :: ColumnsType)

541type family SameTypes (columns0 :: ColumnsType) (columns1 :: ColumnsType)

@@ -532,6 +581,11 @@ type family NullifyRelations (tables :: RelationsType) :: RelationsType where

532 NullifyRelations (table ::: columns ': tables) =

581 NullifyRelations (table ::: columns ': tables) =

533 table ::: NullifyRelation columns ': NullifyRelations tables

582 table ::: NullifyRelation columns ': NullifyRelations tables

534

583

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+

535-- | `Join` is simply promoted `++` and is used in @JOIN@s in

589-- | `Join` is simply promoted `++` and is used in @JOIN@s in

536-- `Squeal.PostgreSQL.Query.FromClause`s.

590-- `Squeal.PostgreSQL.Query.FromClause`s.

537type family Join xs ys where

591type family Join xs ys where

@@ -744,3 +798,9 @@ type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])

744 ConstructorNamesOf '[] = '[]

798 ConstructorNamesOf '[] = '[]

745 ConstructorNamesOf (constructor ': constructors) =

799 ConstructorNamesOf (constructor ': constructors) =

746 ConstructorNameOf constructor ': ConstructorNamesOf constructors

800 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

3+import Test.Hspec

4+import qualified ExceptionHandling

6+main :: IO ()

7+main = hspec ExceptionHandling.specs