Json.hs

{-|
Module: Squeal.PostgreSQL.Expression.Json
Description: json and jsonb functions and operators
Copyright: (c) Eitan Chatav, 2019
Maintainer: eitan@morphism.tech
Stability: experimental

json and jsonb functions and operators
-}

{-# LANGUAGE
    DataKinds
  , FlexibleContexts
  , FlexibleInstances
  , GADTs
  , OverloadedLabels
  , OverloadedStrings
  , PolyKinds
  , RankNTypes
  , ScopedTypeVariables
  , TypeApplications
  , TypeOperators
  , UndecidableInstances
  , UndecidableSuperClasses
#-}

module Squeal.PostgreSQL.Expression.Json
  ( -- * Json and Jsonb Operators
    (.->)
  , (.->>)
  , (.#>)
  , (.#>>)
    -- * Jsonb Operators
  , (.?)
  , (.?|)
  , (.?&)
  , (.-.)
  , (#-.)
    -- * Json and Jsonb Functions
  , toJson
  , toJsonb
  , arrayToJson
  , rowToJson
  , jsonBuildArray
  , jsonbBuildArray
  , JsonBuildObject (..)
  , jsonObject
  , jsonbObject
  , jsonZipObject
  , jsonbZipObject
  , jsonArrayLength
  , jsonbArrayLength
  , jsonTypeof
  , jsonbTypeof
  , jsonStripNulls
  , jsonbStripNulls
  , jsonbSet
  , jsonbInsert
  , jsonbPretty
    -- * Json and Jsonb Set Functions
  , jsonEach
  , jsonbEach
  , jsonEachText
  , jsonArrayElementsText
  , jsonbEachText
  , jsonbArrayElementsText
  , jsonObjectKeys
  , jsonbObjectKeys
  , JsonPopulateFunction
  , jsonPopulateRecord
  , jsonbPopulateRecord
  , jsonPopulateRecordSet
  , jsonbPopulateRecordSet
  , JsonToRecordFunction
  , jsonToRecord
  , jsonbToRecord
  , jsonToRecordSet
  , jsonbToRecordSet
  ) where

import Data.ByteString (ByteString)
import GHC.TypeLits

import Squeal.PostgreSQL.Type.Alias
import Squeal.PostgreSQL.Expression
import Squeal.PostgreSQL.Expression.Type
import Squeal.PostgreSQL.Type.List
import Squeal.PostgreSQL.Query.From
import Squeal.PostgreSQL.Query.From.Set
import Squeal.PostgreSQL.Render
import Squeal.PostgreSQL.Type.Schema

import qualified Generics.SOP as SOP

-- $setup
-- >>> import Squeal.PostgreSQL
-- >>> import Data.Aeson

{-----------------------------------------
 -- 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.
(.->)
  :: (json `In` PGJsonType, key `In` PGJsonKey)
  => Operator (null json) (null key) ('Null json)
infixl 8 .->
(.->) = unsafeBinaryOp "->"

-- | Get JSON value (object field or array element) at a key, as text.
(.->>)
  :: (json `In` PGJsonType, key `In` PGJsonKey)
  => Operator (null json) (null key) ('Null 'PGtext)
infixl 8 .->>
(.->>) = unsafeBinaryOp "->>"

-- | Get JSON value at a specified path.
(.#>)
  :: json `In` PGJsonType
  => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null json)
infixl 8 .#>
(.#>) = unsafeBinaryOp "#>"

-- | Get JSON value at a specified path as text.
(.#>>)
  :: json `In` PGJsonType
  => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null 'PGtext)
infixl 8 .#>>
(.#>>) = unsafeBinaryOp "#>>"

-- Additional jsonb operators

-- | Does the string exist as a top-level key within the JSON value?
(.?) :: Operator (null 'PGjsonb) (null 'PGtext) ('Null 'PGbool)
infixl 9 .?
(.?) = unsafeBinaryOp "?"

-- | Do any of these array strings exist as top-level keys?
(.?|) :: Operator
  (null 'PGjsonb)
  (null ('PGvararray ('NotNull 'PGtext)))
  ('Null 'PGbool)
infixl 9 .?|
(.?|) = unsafeBinaryOp "?|"

-- | Do all of these array strings exist as top-level keys?
(.?&) :: Operator
  (null 'PGjsonb)
  (null ('PGvararray ('NotNull 'PGtext)))
  ('Null 'PGbool)
infixl 9 .?&
(.?&) = 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 ('NotNull 'PGtext), 'PGint4, 'PGint2 ]
  => Operator (null 'PGjsonb) (null key) (null 'PGjsonb)
infixl 6 .-.
(.-.) = unsafeBinaryOp "-"

-- | Delete the field or element with specified path (for JSON arrays, negative
-- integers count from the end)
(#-.) :: Operator (null 'PGjsonb) (null ('PGvararray ('NotNull 'PGtext))) (null 'PGjsonb)
infixl 6 #-.
(#-.) = unsafeBinaryOp "#-"

{-----------------------------------------
Table 9.45: JSON creation functions
-----------------------------------------}

-- | 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 :: null ty --> null '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 :: null ty --> null 'PGjsonb
toJsonb = unsafeFunction "to_jsonb"

-- | Returns the array as a JSON array. A PostgreSQL multidimensional array
-- becomes a JSON array of arrays.
arrayToJson :: null ('PGvararray ty) --> null 'PGjson
arrayToJson = unsafeFunction "array_to_json"

-- | Returns the row as a JSON object.
rowToJson :: null ('PGcomposite ty) --> null 'PGjson
rowToJson = unsafeFunction "row_to_json"

-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic
-- argument list.
jsonBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjson
jsonBuildArray = unsafeFunctionN "json_build_array"

-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a
-- variadic argument list.
jsonbBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjsonb
jsonbBuildArray = unsafeFunctionN "jsonb_build_array"

-- | 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.
class SOP.SListI tys => JsonBuildObject tys where

  jsonBuildObject :: tys ---> null 'PGjson
  jsonBuildObject = unsafeFunctionN "json_build_object"

  jsonbBuildObject :: tys ---> null 'PGjsonb
  jsonbBuildObject = unsafeFunctionN "jsonb_build_object"

instance JsonBuildObject '[]
instance (JsonBuildObject tys, key `In` PGJsonKey)
  => JsonBuildObject ('NotNull key ': value ': tys)

-- | Builds a JSON object out of a text array.
-- The array must have two dimensions
-- such that each inner array has exactly two elements,
-- which are taken as a key/value pair.
jsonObject
  ::   null ('PGfixarray '[n,2] ('NotNull 'PGtext))
  --> null 'PGjson
jsonObject = unsafeFunction "json_object"

-- | Builds a binary JSON object out of a text array.
-- The array must have two dimensions
-- such that each inner array has exactly two elements,
-- which are taken as a key/value pair.
jsonbObject
  ::   null ('PGfixarray '[n,2] ('NotNull 'PGtext))
  --> null '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 ::
  '[ null ('PGvararray ('NotNull 'PGtext))
   , null ('PGvararray ('NotNull 'PGtext)) ]
   ---> null 'PGjson
jsonZipObject = unsafeFunctionN "json_object"

-- | This is an alternate form of 'jsonbObject' that takes two arrays; one for
-- keys and one for values, that are zipped pairwise to create a binary JSON
-- object.
jsonbZipObject ::
  '[ null ('PGvararray ('NotNull 'PGtext))
   , null ('PGvararray ('NotNull 'PGtext)) ]
   ---> null 'PGjsonb
jsonbZipObject = unsafeFunctionN "jsonb_object"

{-----------------------------------------
Table 9.46: JSON processing functions
-----------------------------------------}

-- | Returns the number of elements in the outermost JSON array.
jsonArrayLength :: null 'PGjson --> null 'PGint4
jsonArrayLength = unsafeFunction "json_array_length"

-- | Returns the number of elements in the outermost binary JSON array.
jsonbArrayLength :: null 'PGjsonb --> null 'PGint4
jsonbArrayLength = unsafeFunction "jsonb_array_length"

-- | Returns the type of the outermost JSON value as a text string. Possible
-- types are object, array, string, number, boolean, and null.
jsonTypeof :: null 'PGjson --> null '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 :: null 'PGjsonb --> null 'PGtext
jsonbTypeof = unsafeFunction "jsonb_typeof"

-- | Returns its argument with all object fields that have null values omitted.
-- Other null values are untouched.
jsonStripNulls :: null 'PGjson --> null 'PGjson
jsonStripNulls = unsafeFunction "json_strip_nulls"

-- | Returns its argument with all object fields that have null values omitted.
-- Other null values are untouched.
jsonbStripNulls :: null 'PGjsonb --> null '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
-- `Squeal.PostgreSQL.Expression.Logic.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 ::
  '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
   , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
jsonbSet = unsafeFunctionN "jsonbSet"

-- | @ 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 `Squeal.PostgreSQL.Expression.Logic.true`.
-- 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 ::
  '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
   , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
jsonbInsert = unsafeFunctionN "jsonb_insert"

-- | Returns its argument as indented JSON text.
jsonbPretty :: null 'PGjsonb --> null 'PGtext
jsonbPretty = unsafeFunction "jsonb_pretty"

{- | Expands the outermost JSON object into a set of key/value pairs.

>>> printSQL (select Star (from (jsonEach (inline (Json (object ["a" .= "foo"]))))))
SELECT * FROM json_each(('{"a":"foo"}' :: json))
-}
jsonEach :: null 'PGjson -|->
  ("json_each" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson])
jsonEach = unsafeSetFunction "json_each"

{- | Expands the outermost binary JSON object into a set of key/value pairs.

>>> printSQL (select Star (from (jsonbEach (inline (Jsonb (object ["a" .= "foo"]))))))
SELECT * FROM jsonb_each(('{"a":"foo"}' :: jsonb))
-}
jsonbEach
  :: null 'PGjsonb -|->
    ("jsonb_each" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson])
jsonbEach = unsafeSetFunction "jsonb_each"

{- | Expands the outermost JSON object into a set of key/value pairs.

>>> printSQL (select Star (from (jsonEachText (inline (Json (object ["a" .= "foo"]))))))
SELECT * FROM json_each_text(('{"a":"foo"}' :: json))
-}
jsonEachText
  :: null 'PGjson -|->
    ("json_each_text" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext])
jsonEachText = unsafeSetFunction "json_each_text"

{- | Returns a set of text values from a JSON array

>>> printSQL (select Star (from (jsonArrayElementsText (inline (Json (toJSON ["monkey", "pony", "bear"] ))))))
SELECT * FROM json_array_elements_text(('["monkey","pony","bear"]' :: json))
-}
jsonArrayElementsText
  :: null 'PGjson -|->
    ("json_array_elements_text" ::: '["value" ::: 'NotNull 'PGtext])
jsonArrayElementsText = unsafeSetFunction "json_array_elements_text"

{- | Expands the outermost binary JSON object into a set of key/value pairs.

>>> printSQL (select Star (from (jsonbEachText (inline (Jsonb (object ["a" .= "foo"]))))))
SELECT * FROM jsonb_each_text(('{"a":"foo"}' :: jsonb))
-}
jsonbEachText
  :: null 'PGjsonb -|->
    ("jsonb_each_text" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext])
jsonbEachText = unsafeSetFunction "jsonb_each_text"

{- | Returns set of keys in the outermost JSON object.

>>> printSQL (jsonObjectKeys (inline (Json (object ["a" .= "foo"]))))
json_object_keys(('{"a":"foo"}' :: json))
-}
jsonObjectKeys
  :: null 'PGjson -|->
    ("json_object_keys" ::: '["json_object_keys" ::: 'NotNull 'PGtext])
jsonObjectKeys = unsafeSetFunction "json_object_keys"

{- | Returns set of keys in the outermost JSON object.

>>> printSQL (jsonbObjectKeys (inline (Jsonb (object ["a" .= "foo"]))))
jsonb_object_keys(('{"a":"foo"}' :: jsonb))
-}
jsonbObjectKeys
  :: null 'PGjsonb -|->
    ("jsonb_object_keys" ::: '["jsonb_object_keys" ::: 'NotNull 'PGtext])
jsonbObjectKeys = unsafeSetFunction "jsonb_object_keys"

{- | Returns a set of text values from a binary JSON array

>>> printSQL (select Star (from (jsonbArrayElementsText (inline (Jsonb (toJSON ["red", "green", "cyan"] ))))))
SELECT * FROM jsonb_array_elements_text(('["red","green","cyan"]' :: jsonb))
-}
jsonbArrayElementsText
  :: null 'PGjsonb -|->
    ("jsonb_array_elements_text" ::: '["value" ::: 'NotNull 'PGtext])
jsonbArrayElementsText = unsafeSetFunction "jsonb_array_elements_text"

-- | Build rows from Json types.
type JsonPopulateFunction fun json
  =  forall db row lat with params
  .  json `In` PGJsonType
  => TypeExpression db ('NotNull ('PGcomposite row)) -- ^ row type
  -> Expression 'Ungrouped lat with db params '[] ('NotNull json)
      -- ^ json type
  -> FromClause lat with db params '[fun ::: row]

unsafePopulateFunction
  :: forall fun ty
   . KnownSymbol fun => Alias fun -> JsonPopulateFunction fun ty
unsafePopulateFunction _fun ty expr = UnsafeFromClause $ renderSymbol @fun
  <> parenthesized ("null::" <> renderSQL ty <> ", " <> renderSQL expr)

-- | Expands the JSON expression to a row whose columns match the record
-- type defined by the given table.
jsonPopulateRecord :: JsonPopulateFunction "json_populate_record" 'PGjson
jsonPopulateRecord = unsafePopulateFunction #json_populate_record

-- | Expands the binary JSON expression to a row whose columns match the record
-- type defined by the given table.
jsonbPopulateRecord :: JsonPopulateFunction "jsonb_populate_record" 'PGjsonb
jsonbPopulateRecord = unsafePopulateFunction #jsonb_populate_record

-- | 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.
jsonPopulateRecordSet :: JsonPopulateFunction "json_populate_record_set" 'PGjson
jsonPopulateRecordSet = unsafePopulateFunction #json_populate_record_set

-- | 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.
jsonbPopulateRecordSet :: JsonPopulateFunction "jsonb_populate_record_set" 'PGjsonb
jsonbPopulateRecordSet = unsafePopulateFunction #jsonb_populate_record_set

-- | Build rows from Json types.
type JsonToRecordFunction json
  =  forall lat with db params tab row
  .  (SOP.SListI row, json `In` PGJsonType)
  => Expression 'Ungrouped lat with db params '[] ('NotNull json)
      -- ^ json type
  -> Aliased (NP (Aliased (TypeExpression db))) (tab ::: row)
      -- ^ row type
  -> FromClause lat with db params '[tab ::: row]

unsafeRecordFunction :: ByteString -> JsonToRecordFunction json
unsafeRecordFunction fun expr (types `As` tab) = UnsafeFromClause $
  fun <> parenthesized (renderSQL expr) <+> "AS" <+> renderSQL tab
    <> parenthesized (renderCommaSeparated renderTy types)
    where
      renderTy :: Aliased (TypeExpression db) ty -> ByteString
      renderTy (ty `As` alias) = renderSQL alias <+> renderSQL ty

-- | Builds an arbitrary record from a JSON object.
jsonToRecord :: JsonToRecordFunction 'PGjson
jsonToRecord = unsafeRecordFunction "json_to_record"

-- | Builds an arbitrary record from a binary JSON object.
jsonbToRecord :: JsonToRecordFunction 'PGjsonb
jsonbToRecord = unsafeRecordFunction "jsonb_to_record"

-- | Builds an arbitrary set of records from a JSON array of objects.
jsonToRecordSet :: JsonToRecordFunction 'PGjson
jsonToRecordSet = unsafeRecordFunction "json_to_record_set"

-- | Builds an arbitrary set of records from a binary JSON array of objects.
jsonbToRecordSet :: JsonToRecordFunction 'PGjsonb
jsonbToRecordSet = unsafeRecordFunction "jsonb_to_record_set"