{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Filter operators for JSON values added to PostgreSQL 9.4
module Database.Persist.Postgresql.JSON
  ( (@>.)
  , (<@.)
  , (?.)
  , (?|.)
  , (?&.)
  , Value()
  ) where

import Data.Aeson (FromJSON, ToJSON, Value, encode, eitherDecodeStrict)
import qualified Data.ByteString.Lazy as BSL
import Data.Proxy (Proxy)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding as TE (encodeUtf8)

import Database.Persist (EntityField, Filter(..), PersistValue(..), PersistField(..), PersistFilter(..))
import Database.Persist.Sql (PersistFieldSql(..), SqlType(..))
import Database.Persist.Types (FilterValue(..))


infix 4 @>., <@., ?., ?|., ?&.

-- | This operator checks inclusion of the JSON value
-- on the right hand side in the JSON value on the left
-- hand side.
--
-- === __Objects__
--
-- An empty Object matches any object
--
-- @
-- {}                \@> {} == True
-- {"a":1,"b":false} \@> {} == True
-- @
--
-- Any key-value will be matched top-level
--
-- @
-- {"a":1,"b":{"c":true"}} \@> {"a":1}         == True
-- {"a":1,"b":{"c":true"}} \@> {"b":1}         == False
-- {"a":1,"b":{"c":true"}} \@> {"b":{}}        == True
-- {"a":1,"b":{"c":true"}} \@> {"c":true}      == False
-- {"a":1,"b":{"c":true"}} \@> {"b":{c":true}} == True
-- @
--
-- === __Arrays__
--
-- An empty Array matches any array
--
-- @
-- []                    \@> [] == True
-- [1,2,"hi",false,null] \@> [] == True
-- @
--
-- Any array has to be a sub-set.
-- Any object or array will also be compared as being a subset of.
--
-- @
-- [1,2,"hi",false,null] \@> [1]                       == True
-- [1,2,"hi",false,null] \@> [null,"hi"]               == True
-- [1,2,"hi",false,null] \@> ["hi",true]               == False
-- [1,2,"hi",false,null] \@> ["hi",2,null,false,1]     == True
-- [1,2,"hi",false,null] \@> [1,2,"hi",false,null,{}]  == False
-- @
--
-- Arrays and objects inside arrays match the same way they'd
-- be matched as being on their own.
--
-- @
-- [1,"hi",[false,3],{"a":[null]}] \@> [{}]            == True
-- [1,"hi",[false,3],{"a":[null]}] \@> [{"a":[]}]      == True
-- [1,"hi",[false,3],{"a":[null]}] \@> [{"b":[null]}]  == False
-- [1,"hi",[false,3],{"a":[null]}] \@> [[]]            == True
-- [1,"hi",[false,3],{"a":[null]}] \@> [[3]]           == True
-- [1,"hi",[false,3],{"a":[null]}] \@> [[true,3]]      == False
-- @
--
-- A regular value has to be a member
--
-- @
-- [1,2,"hi",false,null] \@> 1      == True
-- [1,2,"hi",false,null] \@> 5      == False
-- [1,2,"hi",false,null] \@> "hi"   == True
-- [1,2,"hi",false,null] \@> false  == True
-- [1,2,"hi",false,null] \@> "2"    == False
-- @
--
-- An object will never match with an array
--
-- @
-- [1,2,"hi",[false,3],{"a":null}] \@> {}          == False
-- [1,2,"hi",[false,3],{"a":null}] \@> {"a":null}  == False
-- @
--
-- === __Other values__
--
-- For any other JSON values the `(\@>.)` operator
-- functions like an equivalence operator.
--
-- @
-- "hello" \@> "hello"     == True
-- "hello" \@> \"Hello"     == False
-- "hello" \@> "h"         == False
-- "hello" \@> {"hello":1} == False
-- "hello" \@> ["hello"]   == False
--
-- 5       \@> 5       == True
-- 5       \@> 5.00    == True
-- 5       \@> 1       == False
-- 5       \@> 7       == False
-- 12345   \@> 1234    == False
-- 12345   \@> 2345    == False
-- 12345   \@> "12345" == False
-- 12345   \@> [1,2,3,4,5] == False
--
-- true    \@> true    == True
-- true    \@> false   == False
-- false   \@> true    == False
-- true    \@> "true"  == False
--
-- null    \@> null    == True
-- null    \@> 23      == False
-- null    \@> "null"  == False
-- null    \@> {}      == False
-- @
--
-- @since 2.8.2
(@>.) :: EntityField record Value -> Value -> Filter record
@>. :: EntityField record Value -> Value -> Filter record
(@>.) EntityField record Value
field Value
val = EntityField record Value
-> FilterValue Value -> PersistFilter -> Filter record
forall record typ.
PersistField typ =>
EntityField record typ
-> FilterValue typ -> PersistFilter -> Filter record
Filter EntityField record Value
field (Value -> FilterValue Value
forall typ. typ -> FilterValue typ
FilterValue Value
val) (PersistFilter -> Filter record) -> PersistFilter -> Filter record
forall a b. (a -> b) -> a -> b
$ Text -> PersistFilter
BackendSpecificFilter Text
" @> "

-- | Same as '@>.' except the inclusion check is reversed.
-- i.e. is the JSON value on the left hand side included
-- in the JSON value of the right hand side.
--
-- @since 2.8.2
(<@.) :: EntityField record Value -> Value -> Filter record
<@. :: EntityField record Value -> Value -> Filter record
(<@.) EntityField record Value
field Value
val = EntityField record Value
-> FilterValue Value -> PersistFilter -> Filter record
forall record typ.
PersistField typ =>
EntityField record typ
-> FilterValue typ -> PersistFilter -> Filter record
Filter EntityField record Value
field (Value -> FilterValue Value
forall typ. typ -> FilterValue typ
FilterValue Value
val) (PersistFilter -> Filter record) -> PersistFilter -> Filter record
forall a b. (a -> b) -> a -> b
$ Text -> PersistFilter
BackendSpecificFilter Text
" <@ "

-- | This operator takes a column and a string to find a
-- top-level key/field in an object.
--
-- @column ?. string@
--
-- N.B. This operator might have some unexpected interactions
-- with non-object values. Please reference the examples.
--
-- === __Objects__
--
-- @
-- {"a":null}             ? "a"  == True
-- {"test":false,"a":500} ? "a"  == True
-- {"b":{"a":[]}}         ? "a"  == False
-- {}                     ? "a"  == False
-- {}                     ? "{}" == False
-- {}                     ? ""   == False
-- {"":9001}              ? ""   == True
-- @
--
-- === __Arrays__
--
-- This operator will match an array if the string to be matched
-- is an element of that array, but nothing else.
--
-- @
-- ["a"]              ? "a"   == True
-- [["a"]]            ? "a"   == False
-- [9,false,"1",null] ? "1"   == True
-- []                 ? "[]"  == False
-- [{"a":true}]       ? "a"   == False
-- @
--
-- === __Other values__
--
-- This operator functions like an equivalence operator on strings only.
-- Any other value does not match.
--
-- @
-- "a"  ? "a"    == True
-- "1"  ? "1"    == True
-- "ab" ? "a"    == False
-- 1    ? "1"    == False
-- null ? "null" == False
-- true ? "true" == False
-- 1.5  ? "1.5"  == False
-- @
--
-- @since 2.10.0
(?.) :: EntityField record Value -> Text -> Filter record
?. :: EntityField record Value -> Text -> Filter record
(?.) = Text -> EntityField record Value -> Text -> Filter record
forall a record.
PersistField a =>
Text -> EntityField record Value -> a -> Filter record
jsonFilter Text
" ?? "

-- | This operator takes a column and a list of strings to
-- test whether ANY of the elements of the list are top
-- level fields in an object.
--
-- @column ?|. list@
--
-- /N.B. An empty list __will never match anything__. Also, this/
-- /operator might have some unexpected interactions with/
-- /non-object values. Please reference the examples./
--
-- === __Objects__
--
-- @
-- {"a":null}                 ?| ["a","b","c"] == True
-- {"test":false,"a":500}     ?| ["a","b","c"] == True
-- {}                         ?| ["a","{}"]    == False
-- {"b":{"a":[]}}             ?| ["a","c"]     == False
-- {"b":{"a":[]},"test":null} ?| []            == False
-- @
--
-- === __Arrays__
--
-- This operator will match an array if __any__ of the elements
-- of the list are matching string elements of the array.
--
-- @
-- ["a"]              ?| ["a","b","c"] == True
-- [["a"]]            ?| ["a","b","c"] == False
-- [9,false,"1",null] ?| ["a","false"] == False
-- []                 ?| ["a","b","c"] == False
-- []                 ?| []            == False
-- [{"a":true}]       ?| ["a","b","c"] == False
-- [null,4,"b",[]]    ?| ["a","b","c"] == True
-- @
--
-- === __Other values__
--
-- This operator functions much like an equivalence operator
-- on strings only. If a string matches with __any__ element of
-- the given list, the comparison matches. No other values match.
--
-- @
-- "a"  ?| ["a","b","c"] == True
-- "1"  ?| ["a","b","1"] == True
-- "ab" ?| ["a","b","c"] == False
-- 1    ?| ["a","1"]     == False
-- null ?| ["a","null"]  == False
-- true ?| ["a","true"]  == False
-- "a"  ?| []            == False
-- @
--
-- @since 2.10.0
(?|.) :: EntityField record Value -> [Text] -> Filter record
?|. :: EntityField record Value -> [Text] -> Filter record
(?|.) EntityField record Value
field = Text
-> EntityField record Value -> PostgresArray Text -> Filter record
forall a record.
PersistField a =>
Text -> EntityField record Value -> a -> Filter record
jsonFilter Text
" ??| " EntityField record Value
field (PostgresArray Text -> Filter record)
-> ([Text] -> PostgresArray Text) -> [Text] -> Filter record
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> PostgresArray Text
forall a. [a] -> PostgresArray a
PostgresArray

-- | This operator takes a column and a list of strings to
-- test whether ALL of the elements of the list are top
-- level fields in an object.
--
-- @column ?&. list@
--
-- /N.B. An empty list __will match anything__. Also, this/
-- /operator might have some unexpected interactions with/
-- /non-object values. Please reference the examples./
--
-- === __Objects__
--
-- @
-- {"a":null}                 ?& ["a"]         == True
-- {"a":null}                 ?& ["a","a"]     == True
-- {"test":false,"a":500}     ?& ["a"]         == True
-- {"test":false,"a":500}     ?& ["a","b"]     == False
-- {}                         ?& ["{}"]        == False
-- {"b":{"a":[]}}             ?& ["a"]         == False
-- {"b":{"a":[]},"c":false}   ?& ["a","c"]     == False
-- {"a":1,"b":2,"c":3,"d":4}  ?& ["b","d"]     == True
-- {}                         ?& []            == True
-- {"b":{"a":[]},"test":null} ?& []            == True
-- @
--
-- === __Arrays__
--
-- This operator will match an array if __all__ of the elements
-- of the list are matching string elements of the array.
--
-- @
-- ["a"]                   ?& ["a"]         == True
-- ["a"]                   ?& ["a","a"]     == True
-- [["a"]]                 ?& ["a"]         == False
-- ["a","b","c"]           ?& ["a","b","d"] == False
-- [9,"false","1",null]    ?& ["1","false"] == True
-- []                      ?& ["a","b"]     == False
-- [{"a":true}]            ?& ["a"]         == False
-- ["a","b","c","d"]       ?& ["b","c","d"] == True
-- [null,4,{"test":false}] ?& []            == True
-- []                      ?& []            == True
-- @
--
-- === __Other values__
--
-- This operator functions much like an equivalence operator
-- on strings only. If a string matches with all elements of
-- the given list, the comparison matches.
--
-- @
-- "a"   ?& ["a"]     == True
-- "1"   ?& ["a","1"] == False
-- "b"   ?& ["b","b"] == True
-- "ab"  ?& ["a","b"] == False
-- 1     ?& ["1"]     == False
-- null  ?& ["null"]  == False
-- true  ?& ["true"]  == False
-- 31337 ?& []        == True
-- true  ?& []        == True
-- null  ?& []        == True
-- @
--
-- @since 2.10.0
(?&.) :: EntityField record Value -> [Text] -> Filter record
?&. :: EntityField record Value -> [Text] -> Filter record
(?&.) EntityField record Value
field = Text
-> EntityField record Value -> PostgresArray Text -> Filter record
forall a record.
PersistField a =>
Text -> EntityField record Value -> a -> Filter record
jsonFilter Text
" ??& " EntityField record Value
field (PostgresArray Text -> Filter record)
-> ([Text] -> PostgresArray Text) -> [Text] -> Filter record
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> PostgresArray Text
forall a. [a] -> PostgresArray a
PostgresArray

jsonFilter :: PersistField a => Text -> EntityField record Value -> a -> Filter record
jsonFilter :: Text -> EntityField record Value -> a -> Filter record
jsonFilter Text
op EntityField record Value
field a
a = EntityField record Value
-> FilterValue Value -> PersistFilter -> Filter record
forall record typ.
PersistField typ =>
EntityField record typ
-> FilterValue typ -> PersistFilter -> Filter record
Filter EntityField record Value
field (a -> FilterValue Value
forall a typ. PersistField a => a -> FilterValue typ
UnsafeValue a
a) (PersistFilter -> Filter record) -> PersistFilter -> Filter record
forall a b. (a -> b) -> a -> b
$ Text -> PersistFilter
BackendSpecificFilter Text
op


-----------------
-- AESON VALUE --
-----------------

instance PersistField Value where
  toPersistValue :: Value -> PersistValue
toPersistValue = Value -> PersistValue
forall a. ToJSON a => a -> PersistValue
toPersistValueJsonB
  fromPersistValue :: PersistValue -> Either Text Value
fromPersistValue = PersistValue -> Either Text Value
forall a. FromJSON a => PersistValue -> Either Text a
fromPersistValueJsonB

instance PersistFieldSql Value where
  sqlType :: Proxy Value -> SqlType
sqlType = Proxy Value -> SqlType
forall a. (ToJSON a, FromJSON a) => Proxy a -> SqlType
sqlTypeJsonB

-- FIXME: PersistText might be a bit more efficient,
-- but needs testing/profiling before changing it.
-- (When entering into the DB the type isn't as important as fromPersistValue)
toPersistValueJsonB :: ToJSON a => a -> PersistValue
toPersistValueJsonB :: a -> PersistValue
toPersistValueJsonB = ByteString -> PersistValue
PersistLiteralEscaped (ByteString -> PersistValue)
-> (a -> ByteString) -> a -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
encode

fromPersistValueJsonB :: FromJSON a => PersistValue -> Either Text a
fromPersistValueJsonB :: PersistValue -> Either Text a
fromPersistValueJsonB (PersistText Text
t) =
    case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict (ByteString -> Either String a) -> ByteString -> Either String a
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t of
      Left String
str -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
forall a. Show a => Text -> a -> Text -> Text
fromPersistValueParseError Text
"FromJSON" Text
t (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
str
      Right a
v -> a -> Either Text a
forall a b. b -> Either a b
Right a
v
fromPersistValueJsonB (PersistByteString ByteString
bs) =
    case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict ByteString
bs of
      Left String
str -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text -> ByteString -> Text -> Text
forall a. Show a => Text -> a -> Text -> Text
fromPersistValueParseError Text
"FromJSON" ByteString
bs (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
str
      Right a
v -> a -> Either Text a
forall a b. b -> Either a b
Right a
v
fromPersistValueJsonB PersistValue
x = Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"FromJSON" Text
"string or bytea" PersistValue
x

-- Constraints on the type might not be necessary,
-- but better to leave them in.
sqlTypeJsonB :: (ToJSON a, FromJSON a) => Proxy a -> SqlType
sqlTypeJsonB :: Proxy a -> SqlType
sqlTypeJsonB Proxy a
_ = Text -> SqlType
SqlOther Text
"JSONB"


fromPersistValueError :: Text -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64"
                      -> Text -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int".
                      -> PersistValue -- ^ Incorrect value
                      -> Text -- ^ Error message
fromPersistValueError :: Text -> Text -> PersistValue -> Text
fromPersistValueError Text
haskellType Text
databaseType PersistValue
received = [Text] -> Text
T.concat
    [ Text
"Failed to parse Haskell type `"
    , Text
haskellType
    , Text
"`; expected "
    , Text
databaseType
    , Text
" from database, but received: "
    , String -> Text
T.pack (PersistValue -> String
forall a. Show a => a -> String
show PersistValue
received)
    , Text
". Potential solution: Check that your database schema matches your Persistent model definitions."
    ]

fromPersistValueParseError :: (Show a)
                           => Text -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64"
                           -> a -- ^ Received value
                           -> Text -- ^ Additional error
                           -> Text -- ^ Error message
fromPersistValueParseError :: Text -> a -> Text -> Text
fromPersistValueParseError Text
haskellType a
received Text
err = [Text] -> Text
T.concat
    [ Text
"Failed to parse Haskell type `"
    , Text
haskellType
    , Text
"`, but received "
    , String -> Text
T.pack (a -> String
forall a. Show a => a -> String
show a
received)
    , Text
" | with error: "
    , Text
err
    ]

newtype PostgresArray a = PostgresArray [a]

instance PersistField a => PersistField (PostgresArray a) where
  toPersistValue :: PostgresArray a -> PersistValue
toPersistValue (PostgresArray [a]
ts) = [PersistValue] -> PersistValue
PersistArray ([PersistValue] -> PersistValue) -> [PersistValue] -> PersistValue
forall a b. (a -> b) -> a -> b
$ a -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (a -> PersistValue) -> [a] -> [PersistValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
ts
  fromPersistValue :: PersistValue -> Either Text (PostgresArray a)
fromPersistValue (PersistArray [PersistValue]
as) = [a] -> PostgresArray a
forall a. [a] -> PostgresArray a
PostgresArray ([a] -> PostgresArray a)
-> Either Text [a] -> Either Text (PostgresArray a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PersistValue -> Either Text a)
-> [PersistValue] -> Either Text [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse PersistValue -> Either Text a
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue [PersistValue]
as
  fromPersistValue PersistValue
wat = Text -> Either Text (PostgresArray a)
forall a b. a -> Either a b
Left (Text -> Either Text (PostgresArray a))
-> Text -> Either Text (PostgresArray a)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PersistValue -> Text
fromPersistValueError Text
"PostgresArray" Text
"array" PersistValue
wat