diff --git a/squeal-postgresql.cabal b/squeal-postgresql.cabal --- a/squeal-postgresql.cabal +++ b/squeal-postgresql.cabal @@ -1,5 +1,5 @@ name: squeal-postgresql -version: 0.3.1.0 +version: 0.3.2.0 synopsis: Squeal PostgreSQL Library description: Squeal is a type-safe embedding of PostgreSQL in Haskell homepage: https://github.com/morphismtech/squeal diff --git a/src/Squeal/PostgreSQL/Expression.hs b/src/Squeal/PostgreSQL/Expression.hs --- a/src/Squeal/PostgreSQL/Expression.hs +++ b/src/Squeal/PostgreSQL/Expression.hs @@ -11,6 +11,7 @@ {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE AllowAmbiguousTypes + , ConstraintKinds , DeriveGeneric , FlexibleContexts , FlexibleInstances @@ -25,6 +26,7 @@ , TypeInType , TypeOperators , UndecidableInstances + , RankNTypes #-} module Squeal.PostgreSQL.Expression @@ -48,6 +50,7 @@ , unsafeBinaryOp , unsafeUnaryOp , unsafeFunction + , unsafeVariadicFunction , atan2_ , cast , quot_ @@ -83,6 +86,53 @@ , upper , charLength , like + -- ** json or jsonb operators + , PGarray + , PGarrayOf + , PGjsonKey + , PGjson_ + , (.->) + , (.->>) + , (.#>) + , (.#>>) + -- *** jsonb only operators + , (.@>) + , (.<@) + , (.?) + , (.?|) + , (.?&) + , (.-.) + , (#-.) + -- *** Functions + , jsonLit + , jsonbLit + , toJson + , toJsonb + , arrayToJson + , rowToJson + , jsonBuildArray + , jsonbBuildArray + , jsonBuildObject + , jsonbBuildObject + , jsonObject + , jsonbObject + , jsonZipObject + , jsonbZipObject + , jsonArrayLength + , jsonbArrayLength + , jsonExtractPath + , jsonbExtractPath + , jsonExtractPathAsText + , jsonbExtractPathAsText + , jsonObjectKeys + , jsonbObjectKeys + , jsonTypeof + , jsonbTypeof + , jsonStripNulls + , jsonbStripNulls + , jsonbSet + , jsonbInsert + , jsonbPretty -- ** Aggregation , unsafeAggregate, unsafeAggregateDistinct , sum_, sumDistinct @@ -135,8 +185,10 @@ import Control.Category import Control.DeepSeq import Data.ByteString (ByteString) +import Data.ByteString.Lazy (toStrict) import Data.Function ((&)) -import Data.Semigroup +import Data.Semigroup hiding (All) +import qualified Data.Aeson as JSON import Data.Ratio import Data.String import Generics.SOP hiding (from) @@ -477,6 +529,16 @@ unsafeFunction fun x = UnsafeExpression $ fun <> parenthesized (renderExpression x) +-- | Helper for defining variadic functions. +unsafeVariadicFunction + :: SListI elems + => ByteString + -- ^ function + -> NP (Expression schema relations grouping params) elems + -> Expression schema relations grouping params ret +unsafeVariadicFunction fun x = UnsafeExpression $ + fun <> parenthesized (commaSeparated (hcollapse (hmap (K . renderExpression) x))) + instance PGNum ty => Num (Expression schema relations grouping params (nullity ty)) where (+) = unsafeBinaryOp "+" @@ -864,6 +926,400 @@ -- ^ pattern -> Expression schema relations grouping params (nullity 'PGbool) like = unsafeBinaryOp "LIKE" + +{----------------------------------------- + -- json and jsonb support + +See https://www.postgresql.org/docs/10/static/functions-json.html -- most +comments lifted directly from this page. + +Table 9.44: json and jsonb operators +-----------------------------------------} + +-- | Get JSON value (object field or array element) at a key. +(.->) + :: (PGjson_ json, PGjsonKey key) + => Expression schema relations grouping params (nullity json) + -> Expression schema relations grouping params (nullity key) + -> Expression schema relations grouping params ('Null json) +(.->) = unsafeBinaryOp "->" + +-- | Get JSON value (object field or array element) at a key, as text. +(.->>) + :: (PGjson_ json, PGjsonKey key) + => Expression schema relations grouping params (nullity json) + -> Expression schema relations grouping params (nullity key) + -> Expression schema relations grouping params ('Null 'PGtext) +(.->>) = unsafeBinaryOp "->>" + +-- | Get JSON value at a specified path. +(.#>) + :: (PGjson_ json, PGtextArray "(.#>)" path) + => Expression schema relations grouping params (nullity json) + -> Expression schema relations grouping params (nullity path) + -> Expression schema relations grouping params ('Null json) +(.#>) = unsafeBinaryOp "#>" + +-- | Get JSON value at a specified path as text. +(.#>>) + :: (PGjson_ json, PGtextArray "(.#>>)" path) + => Expression schema relations grouping params (nullity json) + -> Expression schema relations grouping params (nullity path) + -> Expression schema relations grouping params ('Null 'PGtext) +(.#>>) = unsafeBinaryOp "#>>" + +-- Additional jsonb operators + +-- | Does the left JSON value contain the right JSON path/value entries at the +-- top level? +(.@>) + :: Expression schema relations grouping params (nullity 'PGjsonb) + -> Expression schema relations grouping params (nullity 'PGjsonb) + -> Condition schema relations grouping params +(.@>) = unsafeBinaryOp "@>" + +-- | Are the left JSON path/value entries contained at the top level within the +-- right JSON value? +(.<@) + :: Expression schema relations grouping params (nullity 'PGjsonb) + -> Expression schema relations grouping params (nullity 'PGjsonb) + -> Condition schema relations grouping params +(.<@) = unsafeBinaryOp "<@" + +-- | Does the string exist as a top-level key within the JSON value? +(.?) + :: Expression schema relations grouping params (nullity 'PGjsonb) + -> Expression schema relations grouping params (nullity 'PGtext) + -> Condition schema relations grouping params +(.?) = unsafeBinaryOp "?" + +-- | Do any of these array strings exist as top-level keys? +(.?|) + :: Expression schema relations grouping params (nullity 'PGjsonb) + -> Expression schema relations grouping params (nullity ('PGvararray 'PGtext)) + -> Condition schema relations grouping params +(.?|) = unsafeBinaryOp "?|" + +-- | Do all of these array strings exist as top-level keys? +(.?&) + :: Expression schema relations grouping params (nullity 'PGjsonb) + -> Expression schema relations grouping params (nullity ('PGvararray 'PGtext)) + -> Condition schema relations grouping params +(.?&) = unsafeBinaryOp "?&" + +-- | Concatenate two jsonb values into a new jsonb value. +instance + Semigroup (Expression schema relations grouping param (nullity 'PGjsonb)) where + (<>) = unsafeBinaryOp "||" + +-- | Delete a key or keys from a JSON object, or remove an array element. +-- +-- If the right operand is.. +-- +-- @ text @: Delete key/value pair or string element from left operand. Key/value pairs +-- are matched based on their key value. +-- +-- @ text[] @: Delete multiple key/value pairs or string elements +-- from left operand. Key/value pairs are matched based on their key value. +-- +-- @ integer @: Delete the array element with specified index (Negative integers +-- count from the end). Throws an error if top level container is not an array. +(.-.) + :: (key `In` '[ 'PGtext, 'PGvararray 'PGtext, 'PGint4, 'PGint2 ]) -- hlint error without parens here + => Expression schema relations grouping params (nullity 'PGjsonb) + -> Expression schema relations grouping params (nullity key) + -> Expression schema relations grouping params (nullity 'PGjsonb) +(.-.) = unsafeBinaryOp "-" + +-- | Delete the field or element with specified path (for JSON arrays, negative +-- integers count from the end) +(#-.) + :: PGtextArray "(#-.)" arrayty + => Expression schema relations grouping params (nullity 'PGjsonb) + -> Expression schema relations grouping params (nullity arrayty) + -> Expression schema relations grouping params (nullity 'PGjsonb) +(#-.) = unsafeBinaryOp "#-" + +{----------------------------------------- +Table 9.45: JSON creation functions +-----------------------------------------} + +-- | Literal binary JSON +jsonbLit :: JSON.Value -> Expression schema relations grouping params (nullity 'PGjsonb) +jsonbLit = cast jsonb . UnsafeExpression . singleQuotedUtf8 . toStrict . JSON.encode + +-- | Literal JSON +jsonLit :: JSON.Value -> Expression schema relations grouping params (nullity 'PGjson) +jsonLit = cast json . UnsafeExpression . singleQuotedUtf8 . toStrict . JSON.encode + +-- | Returns the value as json. Arrays and composites are converted +-- (recursively) to arrays and objects; otherwise, if there is a cast from the +-- type to json, the cast function will be used to perform the conversion; +-- otherwise, a scalar value is produced. For any scalar type other than a +-- number, a Boolean, or a null value, the text representation will be used, in +-- such a fashion that it is a valid json value. +toJson + :: Expression schema relations grouping params (nullity ty) + -> Expression schema relations grouping params (nullity 'PGjson) +toJson = unsafeFunction "to_json" + +-- | Returns the value as jsonb. Arrays and composites are converted +-- (recursively) to arrays and objects; otherwise, if there is a cast from the +-- type to json, the cast function will be used to perform the conversion; +-- otherwise, a scalar value is produced. For any scalar type other than a +-- number, a Boolean, or a null value, the text representation will be used, in +-- such a fashion that it is a valid jsonb value. +toJsonb + :: Expression schema relations grouping params (nullity ty) + -> Expression schema relations grouping params (nullity 'PGjsonb) +toJsonb = unsafeFunction "to_jsonb" + +-- | Returns the array as a JSON array. A PostgreSQL multidimensional array +-- becomes a JSON array of arrays. +arrayToJson + :: PGarray "arrayToJson" arr + => Expression schema relations grouping params (nullity arr) + -> Expression schema relations grouping params (nullity 'PGjson) +arrayToJson = unsafeFunction "array_to_json" + +-- | Returns the row as a JSON object. +rowToJson + :: Expression schema relations grouping params (nullity ('PGcomposite ty)) + -> Expression schema relations grouping params (nullity 'PGjson) +rowToJson = unsafeFunction "row_to_json" + +-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic +-- argument list. +jsonBuildArray + :: SListI elems + => NP (Expression schema relations grouping params) elems + -> Expression schema relations grouping params (nullity 'PGjson) +jsonBuildArray = unsafeVariadicFunction "json_build_array" + +-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a +-- variadic argument list. +jsonbBuildArray + :: SListI elems + => NP (Expression schema relations grouping params) elems + -> Expression schema relations grouping params (nullity 'PGjsonb) +jsonbBuildArray = unsafeVariadicFunction "jsonb_build_array" + +unsafeRowFunction + :: All Top elems + => NP (Aliased (Expression schema relations grouping params)) elems + -> [ByteString] +unsafeRowFunction = + (`appEndo` []) . hcfoldMap (Proxy :: Proxy Top) + (\(col `As` name) -> Endo $ \xs -> + renderAliasString name : renderExpression col : xs) + +-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic +-- argument list. The elements of the argument list must alternate between text +-- and values. +jsonBuildObject + :: All Top elems + => NP (Aliased (Expression schema relations grouping params)) elems + -> Expression schema relations grouping params (nullity 'PGjson) +jsonBuildObject + = unsafeFunction "json_build_object" + . UnsafeExpression + . commaSeparated + . unsafeRowFunction + +-- | Builds a possibly-heterogeneously-typed (binary) JSON object out of a +-- variadic argument list. The elements of the argument list must alternate +-- between text and values. +jsonbBuildObject + :: All Top elems + => NP (Aliased (Expression schema relations grouping params)) elems + -> Expression schema relations grouping params (nullity 'PGjsonb) +jsonbBuildObject + = unsafeFunction "jsonb_build_object" + . UnsafeExpression + . commaSeparated + . unsafeRowFunction + +-- | Builds a JSON object out of a text array. The array must have either +-- exactly one dimension with an even number of members, in which case they are +-- taken as alternating key/value pairs, or two dimensions such that each inner +-- array has exactly two elements, which are taken as a key/value pair. +jsonObject + :: PGarrayOf "jsonObject" arr 'PGtext + => Expression schema relations grouping params (nullity arr) + -> Expression schema relations grouping params (nullity 'PGjson) +jsonObject = unsafeFunction "json_object" + +-- | Builds a binary JSON object out of a text array. The array must have either +-- exactly one dimension with an even number of members, in which case they are +-- taken as alternating key/value pairs, or two dimensions such that each inner +-- array has exactly two elements, which are taken as a key/value pair. +jsonbObject + :: PGarrayOf "jsonbObject" arr 'PGtext + => Expression schema relations grouping params (nullity arr) + -> Expression schema relations grouping params (nullity 'PGjsonb) +jsonbObject = unsafeFunction "jsonb_object" + +-- | This is an alternate form of 'jsonObject' that takes two arrays; one for +-- keys and one for values, that are zipped pairwise to create a JSON object. +jsonZipObject + :: ( PGarrayOf "jsonZipObject" keysArray 'PGtext + , PGarrayOf "jsonZipObject" valuesArray 'PGtext) + => Expression schema relations grouping params (nullity keysArray) + -> Expression schema relations grouping params (nullity valuesArray) + -> Expression schema relations grouping params (nullity 'PGjson) +jsonZipObject ks vs = + unsafeVariadicFunction "json_object" (ks :* vs :* Nil) + +-- | This is an alternate form of 'jsonObject' that takes two arrays; one for +-- keys and one for values, that are zipped pairwise to create a binary JSON +-- object. +jsonbZipObject + :: ( PGarrayOf "jsonbZipObject" keysArray 'PGtext + , PGarrayOf "jsonbZipObject" valuesArray 'PGtext) + => Expression schema relations grouping params (nullity keysArray) + -> Expression schema relations grouping params (nullity valuesArray) + -> Expression schema relations grouping params (nullity 'PGjsonb) +jsonbZipObject ks vs = + unsafeVariadicFunction "jsonb_object" (ks :* vs :* Nil) + +{----------------------------------------- +Table 9.46: JSON processing functions +-----------------------------------------} + +-- | Returns the number of elements in the outermost JSON array. +jsonArrayLength + :: Expression schema relations grouping params (nullity 'PGjson) + -> Expression schema relations grouping params (nullity 'PGint4) +jsonArrayLength = unsafeFunction "json_array_length" + +-- | Returns the number of elements in the outermost binary JSON array. +jsonbArrayLength + :: Expression schema relations grouping params (nullity 'PGjsonb) + -> Expression schema relations grouping params (nullity 'PGint4) +jsonbArrayLength = unsafeFunction "jsonb_array_length" + +-- | Returns JSON value pointed to by the given path (equivalent to #> +-- operator). +jsonExtractPath + :: SListI elems + => Expression schema relations grouping params (nullity 'PGjson) + -> NP (Expression schema relations grouping params) elems + -> Expression schema relations grouping params (nullity 'PGjsonb) +jsonExtractPath x xs = + unsafeVariadicFunction "json_extract_path" (x :* xs) + +-- | Returns JSON value pointed to by the given path (equivalent to #> +-- operator). +jsonbExtractPath + :: SListI elems + => Expression schema relations grouping params (nullity 'PGjsonb) + -> NP (Expression schema relations grouping params) elems + -> Expression schema relations grouping params (nullity 'PGjsonb) +jsonbExtractPath x xs = + unsafeVariadicFunction "jsonb_extract_path" (x :* xs) + +-- | Returns JSON value pointed to by the given path (equivalent to #> +-- operator), as text. +jsonExtractPathAsText + :: SListI elems + => Expression schema relations grouping params (nullity 'PGjson) + -> NP (Expression schema relations grouping params) elems + -> Expression schema relations grouping params (nullity 'PGjson) +jsonExtractPathAsText x xs = + unsafeVariadicFunction "json_extract_path_text" (x :* xs) + +-- | Returns JSON value pointed to by the given path (equivalent to #> +-- operator), as text. +jsonbExtractPathAsText + :: SListI elems + => Expression schema relations grouping params (nullity 'PGjsonb) + -> NP (Expression schema relations grouping params) elems + -> Expression schema relations grouping params (nullity 'PGjsonb) +jsonbExtractPathAsText x xs = + unsafeVariadicFunction "jsonb_extract_path_text" (x :* xs) + +-- | Returns set of keys in the outermost JSON object. +jsonObjectKeys + :: Expression schema relations grouping params (nullity 'PGjson) + -> Expression schema relations grouping params (nullity 'PGtext) +jsonObjectKeys = unsafeFunction "json_object_keys" + +-- | Returns set of keys in the outermost JSON object. +jsonbObjectKeys + :: Expression schema relations grouping params (nullity 'PGjsonb) + -> Expression schema relations grouping params (nullity 'PGtext) +jsonbObjectKeys = unsafeFunction "jsonb_object_keys" + +-- | Returns the type of the outermost JSON value as a text string. Possible +-- types are object, array, string, number, boolean, and null. +jsonTypeof + :: Expression schema relations grouping params (nullity 'PGjson) + -> Expression schema relations grouping params (nullity 'PGtext) +jsonTypeof = unsafeFunction "json_typeof" + +-- | Returns the type of the outermost binary JSON value as a text string. +-- Possible types are object, array, string, number, boolean, and null. +jsonbTypeof + :: Expression schema relations grouping params (nullity 'PGjsonb) + -> Expression schema relations grouping params (nullity 'PGtext) +jsonbTypeof = unsafeFunction "jsonb_typeof" + +-- | Returns its argument with all object fields that have null values omitted. +-- Other null values are untouched. +jsonStripNulls + :: Expression schema relations grouping params (nullity 'PGjson) + -> Expression schema relations grouping params (nullity 'PGjson) +jsonStripNulls = unsafeFunction "json_strip_nulls" + +-- | Returns its argument with all object fields that have null values omitted. +-- Other null values are untouched. +jsonbStripNulls + :: Expression schema relations grouping params (nullity 'PGjsonb) + -> Expression schema relations grouping params (nullity 'PGjsonb) +jsonbStripNulls = unsafeFunction "jsonb_strip_nulls" + +-- | @ jsonbSet target path new_value create_missing @ +-- +-- Returns target with the section designated by path replaced by new_value, +-- or with new_value added if create_missing is true ( default is true) and the +-- item designated by path does not exist. As with the path orientated +-- operators, negative integers that appear in path count from the end of JSON +-- arrays. +jsonbSet + :: PGtextArray "jsonbSet" arr + => Expression schema relations grouping params (nullity 'PGjsonb) + -> Expression schema relations grouping params (nullity arr) + -> Expression schema relations grouping params (nullity 'PGjsonb) + -> Maybe (Expression schema relations grouping params (nullity 'PGbool)) + -> Expression schema relations grouping params (nullity 'PGjsonb) +jsonbSet tgt path val createMissing = case createMissing of + Just m -> unsafeVariadicFunction "jsonb_set" (tgt :* path :* val :* m :* Nil) + Nothing -> unsafeVariadicFunction "jsonb_set" (tgt :* path :* val :* Nil) + +-- | @ jsonbInsert target path new_value insert_after @ +-- +-- Returns target with new_value inserted. If target section designated by +-- path is in a JSONB array, new_value will be inserted before target or after +-- if insert_after is true (default is false). If target section designated by +-- path is in JSONB object, new_value will be inserted only if target does not +-- exist. As with the path orientated operators, negative integers that appear +-- in path count from the end of JSON arrays. +jsonbInsert + :: PGtextArray "jsonbInsert" arr + => Expression schema relations grouping params (nullity 'PGjsonb) + -> Expression schema relations grouping params (nullity arr) + -> Expression schema relations grouping params (nullity 'PGjsonb) + -> Maybe (Expression schema relations grouping params (nullity 'PGbool)) + -> Expression schema relations grouping params (nullity 'PGjsonb) +jsonbInsert tgt path val insertAfter = case insertAfter of + Just i -> unsafeVariadicFunction "jsonb_insert" (tgt :* path :* val :* i :* Nil) + Nothing -> unsafeVariadicFunction "jsonb_insert" (tgt :* path :* val :* Nil) + +-- | Returns its argument as indented JSON text. +jsonbPretty + :: Expression schema relations grouping params (nullity 'PGjsonb) + -> Expression schema relations grouping params (nullity 'PGtext) +jsonbPretty = unsafeFunction "jsonb_pretty" {----------------------------------------- aggregation diff --git a/src/Squeal/PostgreSQL/Pool.hs b/src/Squeal/PostgreSQL/Pool.hs --- a/src/Squeal/PostgreSQL/Pool.hs +++ b/src/Squeal/PostgreSQL/Pool.hs @@ -41,7 +41,28 @@ import Squeal.PostgreSQL.PQ import Squeal.PostgreSQL.Schema --- | `PoolPQ` @schema@ should be a drop-in replacement for `PQ` @schema schema@. +{- | `PoolPQ` @schema@ should be a drop-in replacement for `PQ` @schema schema@. + +Typical use case would be to create your pool using `createConnectionPool` and run anything that requires the pool connection with it. + +Here's a simplified example: + +> type Schema = '[ "tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint2])] +> +> someQuery :: Manipulation Schema '[ 'NotNull 'PGint2] '[] +> someQuery = insertRow #tab +> (Set (param @1) `As` #col :* Nil) +> OnConflictDoNothing (Returning Nil) +> +> insertOne :: (MonadBaseControl IO m, MonadPQ Schema m) => m () +> insertOne = void $ manipulateParams someQuery . Only $ (1 :: Int16) +> +> insertOneInPool :: ByteString -> IO () +> insertOneInPool connectionString = do +> pool <- createConnectionPool connectionString 1 0.5 10 +> liftIO $ runPoolPQ (insertOne) pool + +-} newtype PoolPQ (schema :: SchemaType) m x = PoolPQ { runPoolPQ :: Pool (K Connection schema) -> m x } deriving Functor diff --git a/src/Squeal/PostgreSQL/Query.hs b/src/Squeal/PostgreSQL/Query.hs --- a/src/Squeal/PostgreSQL/Query.hs +++ b/src/Squeal/PostgreSQL/Query.hs @@ -9,7 +9,8 @@ -} {-# LANGUAGE - DeriveGeneric + ConstraintKinds + , DeriveGeneric , FlexibleContexts , FlexibleInstances , GADTs @@ -21,8 +22,9 @@ , TypeFamilies , TypeInType , TypeOperators + , RankNTypes , UndecidableInstances -#-} + #-} module Squeal.PostgreSQL.Query ( -- * Queries @@ -52,6 +54,21 @@ , orderBy , limit , offset + -- ** JSON table expressions + , PGjson_each + , PGjsonb_each + , jsonEach + , jsonbEach + , jsonEachAsText + , jsonbEachAsText + , jsonPopulateRecordAs + , jsonbPopulateRecordAs + , jsonPopulateRecordSetAs + , jsonbPopulateRecordSetAs + , jsonToRecordAs + , jsonbToRecordAs + , jsonToRecordSetAs + , jsonbToRecordSetAs -- * From , FromClause (..) , table @@ -626,6 +643,189 @@ -> TableExpression schema params relations grouping -> TableExpression schema params relations grouping offset off rels = rels {offsetClause = off : offsetClause rels} + +{----------------------------------------- +JSON stuff +-----------------------------------------} + +type PGjson_each_variant val tab = + '[ tab ::: '[ "key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull val ] ] + +-- | The type of a `json_each` `FromClause`. +type PGjson_each tab = PGjson_each_variant 'PGjson tab +-- | The type of a `jsonb_each` `FromClause`. +type PGjsonb_each tab = PGjson_each_variant 'PGjsonb tab +-- | The type of a `json_each_text` `FromClause`. +type PGjson_each_text tab = PGjson_each_variant 'PGtext tab +-- | The type of a `jsonb_each_text` `FromClause`. +type PGjsonb_each_text tab = PGjson_each_variant 'PGtext tab + +unsafeAliasedFromClauseExpression + :: Aliased (Expression schema' relations' grouping' params') ty' + -> FromClause schema params relations +unsafeAliasedFromClauseExpression aliasedExpr = UnsafeFromClause + (renderAliasedAs renderExpression aliasedExpr) + +-- | Expands the outermost JSON object into a set of key/value pairs. +jsonEach + :: Aliased (Expression schema '[] 'Ungrouped params) '(tab, nullity 'PGjson) + -> FromClause schema params (PGjson_each tab) +jsonEach (As jexpr jname) = unsafeAliasedFromClauseExpression + (As (unsafeFunction "json_each" jexpr) jname) + +-- | Expands the outermost binary JSON object into a set of key/value pairs. +jsonbEach + :: Aliased (Expression schema '[] 'Ungrouped params) '(tab, nullity 'PGjsonb) + -> FromClause schema params (PGjsonb_each tab) +jsonbEach (As jexpr jname) = unsafeAliasedFromClauseExpression + (As (unsafeFunction "jsonb_each" jexpr) jname) + +-- | Expands the outermost JSON object into a set of key/value pairs. +jsonEachAsText + :: Aliased (Expression schema '[] 'Ungrouped params) '(tab, nullity 'PGjson) + -> FromClause schema params (PGjson_each_text tab) +jsonEachAsText (As jexpr jname) = unsafeAliasedFromClauseExpression + (As (unsafeFunction "json_each" jexpr) jname) + +-- | Expands the outermost binary JSON object into a set of key/value pairs. +jsonbEachAsText + :: Aliased (Expression schema '[] 'Ungrouped params) '(tab, nullity 'PGjsonb) + -> FromClause schema params (PGjsonb_each_text tab) +jsonbEachAsText (As jexpr jname) = unsafeAliasedFromClauseExpression + (As (unsafeFunction "jsonb_each" jexpr) jname) + +nullRow + :: Has tab schema ('Table table) + => Alias tab + -> Expression schema relations grouping params + (nullity ('PGcomposite (RelationToRowType (TableToRelation table)))) +nullRow tab = UnsafeExpression ("null::"<+>renderAlias tab) + +-- | Expands the JSON expression to a row whose columns match the record +-- type defined by the given table. +jsonPopulateRecordAs + :: (KnownSymbol alias, Has tab schema ('Table table)) + => Alias tab + -> Expression schema '[] 'Ungrouped params (nullity 'PGjson) + -> Alias alias + -> FromClause schema params '[alias ::: TableToRelation table] +jsonPopulateRecordAs tableName expr alias = unsafeAliasedFromClauseExpression + (unsafeVariadicFunction "json_populate_record" + (nullRow tableName :* expr :* Nil) `As` alias) + +-- | Expands the binary JSON expression to a row whose columns match the record +-- type defined by the given table. +jsonbPopulateRecordAs + :: (KnownSymbol alias, Has tab schema ('Table table)) + => Alias tab + -> Expression schema '[] 'Ungrouped params (nullity 'PGjsonb) + -> Alias alias + -> FromClause schema params '[alias ::: TableToRelation table] +jsonbPopulateRecordAs tableName expr alias = unsafeAliasedFromClauseExpression + (unsafeVariadicFunction "jsonb_populate_record" + (nullRow tableName :* expr :* Nil) `As` alias) + +-- | Expands the outermost array of objects in the given JSON expression to a +-- set of rows whose columns match the record type defined by the given table. +jsonPopulateRecordSetAs + :: (KnownSymbol alias, Has tab schema ('Table table)) + => Alias tab + -> Expression schema '[] 'Ungrouped params (nullity 'PGjson) + -> Alias alias + -> FromClause schema params '[alias ::: TableToRelation table] +jsonPopulateRecordSetAs tableName expr alias = unsafeAliasedFromClauseExpression + (unsafeVariadicFunction "json_populate_record_set" + (nullRow tableName :* expr :* Nil) `As` alias) + +-- | Expands the outermost array of objects in the given binary JSON expression +-- to a set of rows whose columns match the record type defined by the given +-- table. +jsonbPopulateRecordSetAs + :: (KnownSymbol alias, Has tab schema ('Table table)) + => Alias tab + -> Expression schema '[] 'Ungrouped params (nullity 'PGjsonb) + -> Alias alias + -> FromClause schema params '[alias ::: TableToRelation table] +jsonbPopulateRecordSetAs tableName expr alias = unsafeAliasedFromClauseExpression + (unsafeVariadicFunction "jsonb_populate_record_set" + (nullRow tableName :* expr :* Nil) `As` alias) + +renderTableTypeExpression + :: All Top types + => Aliased (NP (Aliased (TypeExpression schema))) (tab ::: types) + -> ByteString +renderTableTypeExpression (hc `As` tab) + = (renderAlias tab <>) + . parenthesized + . commaSeparated + . flip appEndo [] + . hcfoldMap + (Proxy :: Proxy Top) + (\(ty `As` name) -> Endo + ((renderAlias name <+> renderTypeExpression ty):)) + $ hc + +unsafeTableAliasedFromClauseExpression + :: All Top types + => Expression schema' relations' grouping' params' ty' + -> Aliased (NP (Aliased (TypeExpression schema))) (tab ::: types) + -> FromClause schema params '[alias ::: types] +unsafeTableAliasedFromClauseExpression expr types = UnsafeFromClause + (renderExpression expr + <+> "AS" + <+> renderTableTypeExpression types) + +-- | Builds an arbitrary record from a JSON object. As with all functions +-- returning record, the caller must explicitly define the structure of the +-- record with an AS clause. +jsonToRecordAs + :: All Top types + => Expression schema '[] 'Ungrouped params (nullity 'PGjson) + -> Aliased (NP (Aliased (TypeExpression schema))) (tab ::: types) + -> FromClause schema params '[tab ::: types] +jsonToRecordAs expr types = + unsafeTableAliasedFromClauseExpression + (unsafeFunction "json_to_record" expr) + types + +-- | Builds an arbitrary record from a binary JSON object. As with all functions +-- returning record, the caller must explicitly define the structure of the +-- record with an AS clause. +jsonbToRecordAs + :: All Top types + => Expression schema '[] 'Ungrouped params (nullity 'PGjsonb) + -> Aliased (NP (Aliased (TypeExpression schema))) (tab ::: types) + -> FromClause schema params '[tab ::: types] +jsonbToRecordAs expr types = + unsafeTableAliasedFromClauseExpression + (unsafeFunction "jsonb_to_record" expr) + types + +-- | Builds an arbitrary set of records from a JSON array of objects (see note +-- below). As with all functions returning record, the caller must explicitly +-- define the structure of the record with an AS clause. +jsonToRecordSetAs + :: All Top types + => Expression schema '[] 'Ungrouped params (nullity 'PGjson) + -> Aliased (NP (Aliased (TypeExpression schema))) (tab ::: types) + -> FromClause schema params '[tab ::: types] +jsonToRecordSetAs expr types = + unsafeTableAliasedFromClauseExpression + (unsafeFunction "json_to_recordset" expr) + types + +-- | Builds an arbitrary set of records from a binary JSON array of objects (see +-- note below). As with all functions returning record, the caller must +-- explicitly define the structure of the record with an AS clause. +jsonbToRecordSetAs + :: All Top types + => Expression schema '[] 'Ungrouped params (nullity 'PGjsonb) + -> Aliased (NP (Aliased (TypeExpression schema))) (tab ::: types) + -> FromClause schema params '[tab ::: types] +jsonbToRecordSetAs expr types = + unsafeTableAliasedFromClauseExpression + (unsafeFunction "jsonb_to_recordset" expr) + types {----------------------------------------- FROM clauses diff --git a/src/Squeal/PostgreSQL/Render.hs b/src/Squeal/PostgreSQL/Render.hs --- a/src/Squeal/PostgreSQL/Render.hs +++ b/src/Squeal/PostgreSQL/Render.hs @@ -23,6 +23,8 @@ , (<+>) , commaSeparated , doubleQuoted + , singleQuotedText + , singleQuotedUtf8 , renderCommaSeparated , renderCommaSeparatedMaybe , renderNat @@ -34,10 +36,12 @@ import Data.ByteString (ByteString) import Data.Maybe import Data.Monoid ((<>)) +import Data.Text (Text) import Generics.SOP import GHC.Exts import GHC.TypeLits - +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 as Char8 @@ -56,6 +60,14 @@ -- | Add double quotes around a `ByteString`. doubleQuoted :: ByteString -> ByteString doubleQuoted str = "\"" <> str <> "\"" + +-- | Add single quotes around a `Text` and escape single quotes within it. +singleQuotedText :: Text -> ByteString +singleQuotedText str = "'" <> T.encodeUtf8 (T.replace "'" "''" str) <> "'" + +-- | Add single quotes around a `ByteString` and escape single quotes within it. +singleQuotedUtf8 :: ByteString -> ByteString +singleQuotedUtf8 = singleQuotedText . T.decodeUtf8 -- | Comma separate the renderings of a heterogeneous list. renderCommaSeparated diff --git a/src/Squeal/PostgreSQL/Schema.hs b/src/Squeal/PostgreSQL/Schema.hs --- a/src/Squeal/PostgreSQL/Schema.hs +++ b/src/Squeal/PostgreSQL/Schema.hs @@ -10,7 +10,7 @@ It also defines useful type families to operate on these. Finally, it defines an embedding of Haskell types into Postgres types. -} - +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} {-# LANGUAGE AllowAmbiguousTypes , ConstraintKinds @@ -69,6 +69,7 @@ , HasAll , IsLabel (..) , IsQualified (..) + , renderAliasString -- * Enumerated Labels , IsPGlabel (..) , PGlabel (..) @@ -90,6 +91,9 @@ , PGIntegral , PGFloating , PGTypeOf + , PGarrayOf + , PGarray + , PGtextArray , SameTypes , SamePGType , AllNotNull @@ -100,8 +104,13 @@ , ColumnsToRelation , TableToColumns , TableToRelation + , RelationToRowType + , RelationToNullityTypes , ConstraintInvolves , DropIfConstraintsInvolve + -- ** JSON support + , PGjson_ + , PGjsonKey -- * Embedding , PG , EnumFrom @@ -371,6 +380,11 @@ renderAlias :: KnownSymbol alias => Alias alias -> ByteString renderAlias = doubleQuoted . fromString . symbolVal +-- | >>> renderAliasString #ohmahgerd +-- "'ohmahgerd'" +renderAliasString :: KnownSymbol alias => Alias alias -> ByteString +renderAliasString = singleQuotedText . fromString . symbolVal + -- | >>> import Generics.SOP (NP(..)) -- >>> renderAliases (#jimbob :* #kandi) -- ["\"jimbob\"","\"kandi\""] @@ -524,6 +538,37 @@ -- `Squeal.PostgreSQL.Expression.mod_` functions. type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8] +-- | Error message helper for displaying unavailable\/unknown\/placeholder type +-- variables whose kind is known. +type Placeholder k = 'Text "(_::" :<>: 'ShowType k :<>: 'Text ")" + +type ErrArrayOf arr ty = arr :<>: 'Text " " :<>: ty +type ErrPGfixarrayOf t = ErrArrayOf ('ShowType 'PGfixarray :<>: 'Text " " :<>: Placeholder Nat) t +type ErrPGvararrayOf t = ErrArrayOf ('ShowType 'PGvararray) t + +-- | Ensure a type is a valid array type. +type family PGarray name arr :: Constraint where + PGarray name ('PGvararray x) = () + PGarray name ('PGfixarray n x) = () + PGarray name val = TypeError + ('Text name :<>: 'Text ": Unsatisfied PGarray constraint. Expected either: " + :$$: 'Text " • " :<>: ErrPGvararrayOf (Placeholder PGType) + :$$: 'Text " • " :<>: ErrPGfixarrayOf (Placeholder PGType) + :$$: 'Text "But got: " :<>: 'ShowType val) + +-- | Ensure a type is a valid array type with a specific element type. +type family PGarrayOf name arr ty :: Constraint where + PGarrayOf name ('PGvararray x) ty = x ~ ty + PGarrayOf name ('PGfixarray n x) ty = x ~ ty + PGarrayOf name val ty = TypeError + ( 'Text name :<>: 'Text "Unsatisfied PGarrayOf constraint. Expected either: " + :$$: 'Text " • " :<>: ErrPGvararrayOf ( 'ShowType ty ) + :$$: 'Text " • " :<>: ErrPGfixarrayOf ( 'ShowType ty ) + :$$: 'Text "But got: " :<>: 'ShowType val) + +-- | Ensure a type is a valid array type whose elements are text. +type PGtextArray name arr = PGarrayOf name arr 'PGtext + -- | `PGTypeOf` forgets about @NULL@ and any column constraints. type family PGTypeOf (ty :: NullityType) :: PGType where PGTypeOf (nullity pg) = pg @@ -573,6 +618,16 @@ NullifyRelations (table ::: columns ': tables) = table ::: NullifyRelation columns ': NullifyRelations tables +-- | `RelationToRowType` drops the nullity constraints of its argument relations. +type family RelationToRowType (tables :: RelationType) :: [(Symbol, PGType)] where + RelationToRowType (nullity x : xs) = x : RelationToRowType xs + RelationToRowType '[] = '[] + +-- | `RelationToNullityTypes` drops the column constraints. +type family RelationToNullityTypes (rel :: RelationType) :: [NullityType] where + RelationToNullityTypes ('(k, x) : xs) = x : RelationToNullityTypes xs + RelationToNullityTypes '[] = '[] + -- | `Join` is simply promoted `++` and is used in @JOIN@s in -- `Squeal.PostgreSQL.Query.FromClause`s. type family Join xs ys where @@ -857,3 +912,10 @@ RecordCodeOf _hask '[tys] = tys RecordCodeOf hask _tys = TypeError ('Text "RecordCodeOf error: non-Record type " ':<>: 'ShowType hask) + +-- | Is a type a valid JSON key? +type PGjsonKey key = key `In` '[ 'PGint2, 'PGint4, 'PGtext ] + +-- | Is a type a valid JSON type? +type PGjson_ json = json `In` '[ 'PGjson, 'PGjsonb ] +