{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
--------------------------------------------------------------------------------
-- |
-- Module      : Typson.Beam
-- Description : Provides the Beam integration
-- Copyright   : (c) Aaron Allen, 2020
-- Maintainer  : Aaron Allen <aaronallen8455@gmail.com>
-- License     : BSD-style (see the file LICENSE)
-- Stability   : experimental
-- Portability : non-portable
--
--------------------------------------------------------------------------------
module Typson.Beam
  ( jsonPath
  , JNullable(..)
  , nullableJsonb
  , nullableJson
  ) where

import qualified Data.Aeson as Aeson
import           Data.Coerce (Coercible, coerce)
import           Data.Kind (Type)
import           Data.List (foldl')
import qualified Data.List.NonEmpty as NE
import           Data.Maybe (fromMaybe)
import           Data.String (fromString)
import qualified Database.Beam as B
import qualified Database.Beam.Backend.SQL.SQL92 as B (HasSqlValueSyntax)
import qualified Database.Beam.Postgres as B
import qualified Database.PostgreSQL.Simple.FromField as Pg

import           Typson

-- | Use a type-safe JSON path as part of a query.
--
-- @
-- select $ jsonPath (Proxy @("foo" :-> "bar")) fieldSchemaJ
--        . fieldAccessor
--      \<$> all_ someTable
-- @
jsonPath :: ( TypeAtPath o tree path ~ field
            , ReflectPath path
            , B.IsPgJSON json
            , Coercible (json field) (JNullable json' field)
            )
         => proxy (path :: k) -- ^ A path proxy
         -> ObjectTree tree o -- ^ Typson schema
         -> B.QGenExpr ctxt B.Postgres s (json o) -- ^ Column selector
         -> B.QGenExpr ctxt B.Postgres s (JNullable json' field)
jsonPath :: proxy path
-> ObjectTree tree o
-> QGenExpr ctxt Postgres s (json o)
-> QGenExpr ctxt Postgres s (JNullable json' field)
jsonPath proxy path
path ObjectTree tree o
_ QGenExpr ctxt Postgres s (json o)
input = QGenExpr ctxt Postgres s (json Any)
-> QGenExpr ctxt Postgres s (JNullable json' field)
coerce (QGenExpr ctxt Postgres s (json Any)
 -> QGenExpr ctxt Postgres s (JNullable json' field))
-> QGenExpr ctxt Postgres s (json Any)
-> QGenExpr ctxt Postgres s (JNullable json' field)
forall a b. (a -> b) -> a -> b
$
  case proxy path -> NonEmpty PathComponent
forall k (path :: k) (proxy :: k -> *).
ReflectPath path =>
proxy path -> NonEmpty PathComponent
reflectPath proxy path
path of
    PathComponent
p NE.:| [PathComponent]
ps -> (QGenExpr ctxt Postgres s (json Any)
 -> PathComponent -> QGenExpr ctxt Postgres s (json Any))
-> QGenExpr ctxt Postgres s (json Any)
-> [PathComponent]
-> QGenExpr ctxt Postgres s (json Any)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' QGenExpr ctxt Postgres s (json Any)
-> PathComponent -> QGenExpr ctxt Postgres s (json Any)
forall (json :: * -> *) ctxt s a b.
IsPgJSON json =>
QGenExpr ctxt Postgres s (json a)
-> PathComponent -> QGenExpr ctxt Postgres s (json b)
buildPath (QGenExpr ctxt Postgres s (json o)
-> PathComponent -> QGenExpr ctxt Postgres s (json Any)
forall (json :: * -> *) ctxt s a b.
IsPgJSON json =>
QGenExpr ctxt Postgres s (json a)
-> PathComponent -> QGenExpr ctxt Postgres s (json b)
buildPath QGenExpr ctxt Postgres s (json o)
input PathComponent
p) [PathComponent]
ps
  where
    buildPath :: QGenExpr ctxt Postgres s (json a)
-> PathComponent -> QGenExpr ctxt Postgres s (json b)
buildPath QGenExpr ctxt Postgres s (json a)
p (Key String
k) = QGenExpr ctxt Postgres s (json a)
p QGenExpr ctxt Postgres s (json a)
-> QGenExpr ctxt Postgres s Text
-> QGenExpr ctxt Postgres s (json b)
forall (json :: * -> *) ctxt s a b.
IsPgJSON json =>
QGenExpr ctxt Postgres s (json a)
-> QGenExpr ctxt Postgres s Text
-> QGenExpr ctxt Postgres s (json b)
B.->$ String -> QGenExpr ctxt Postgres s Text
forall a. IsString a => String -> a
fromString String
k
    buildPath QGenExpr ctxt Postgres s (json a)
p (Idx Integer
i) = QGenExpr ctxt Postgres s (json a)
p QGenExpr ctxt Postgres s (json a)
-> QGenExpr ctxt Postgres s Int32
-> QGenExpr ctxt Postgres s (json b)
forall (json :: * -> *) ctxt s a b.
IsPgJSON json =>
QGenExpr ctxt Postgres s (json a)
-> QGenExpr ctxt Postgres s Int32
-> QGenExpr ctxt Postgres s (json b)
B.-># Integer -> QGenExpr ctxt Postgres s Int32
forall a. Num a => Integer -> a
fromInteger Integer
i

--------------------------------------------------------------------------------
-- Selecting Optional JSON
--------------------------------------------------------------------------------

-- | Wraps a @PgJSON@ or @PgJSONB@, treating deserialization of SQL @NULL@ as
-- json @null@. This is so that if you query for a path that might not exist,
-- i.e. a path into an optional field, then an exception will not be raised
-- when attempting to decode the result as JSON.
newtype JNullable json a = JNullable (json a)
  deriving (Eq (JNullable json a)
Eq (JNullable json a)
-> (JNullable json a -> JNullable json a -> Ordering)
-> (JNullable json a -> JNullable json a -> Bool)
-> (JNullable json a -> JNullable json a -> Bool)
-> (JNullable json a -> JNullable json a -> Bool)
-> (JNullable json a -> JNullable json a -> Bool)
-> (JNullable json a -> JNullable json a -> JNullable json a)
-> (JNullable json a -> JNullable json a -> JNullable json a)
-> Ord (JNullable json a)
JNullable json a -> JNullable json a -> Bool
JNullable json a -> JNullable json a -> Ordering
JNullable json a -> JNullable json a -> JNullable json a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall k (json :: k -> *) (a :: k).
Ord (json a) =>
Eq (JNullable json a)
forall k (json :: k -> *) (a :: k).
Ord (json a) =>
JNullable json a -> JNullable json a -> Bool
forall k (json :: k -> *) (a :: k).
Ord (json a) =>
JNullable json a -> JNullable json a -> Ordering
forall k (json :: k -> *) (a :: k).
Ord (json a) =>
JNullable json a -> JNullable json a -> JNullable json a
min :: JNullable json a -> JNullable json a -> JNullable json a
$cmin :: forall k (json :: k -> *) (a :: k).
Ord (json a) =>
JNullable json a -> JNullable json a -> JNullable json a
max :: JNullable json a -> JNullable json a -> JNullable json a
$cmax :: forall k (json :: k -> *) (a :: k).
Ord (json a) =>
JNullable json a -> JNullable json a -> JNullable json a
>= :: JNullable json a -> JNullable json a -> Bool
$c>= :: forall k (json :: k -> *) (a :: k).
Ord (json a) =>
JNullable json a -> JNullable json a -> Bool
> :: JNullable json a -> JNullable json a -> Bool
$c> :: forall k (json :: k -> *) (a :: k).
Ord (json a) =>
JNullable json a -> JNullable json a -> Bool
<= :: JNullable json a -> JNullable json a -> Bool
$c<= :: forall k (json :: k -> *) (a :: k).
Ord (json a) =>
JNullable json a -> JNullable json a -> Bool
< :: JNullable json a -> JNullable json a -> Bool
$c< :: forall k (json :: k -> *) (a :: k).
Ord (json a) =>
JNullable json a -> JNullable json a -> Bool
compare :: JNullable json a -> JNullable json a -> Ordering
$ccompare :: forall k (json :: k -> *) (a :: k).
Ord (json a) =>
JNullable json a -> JNullable json a -> Ordering
$cp1Ord :: forall k (json :: k -> *) (a :: k).
Ord (json a) =>
Eq (JNullable json a)
Ord, JNullable json a -> JNullable json a -> Bool
(JNullable json a -> JNullable json a -> Bool)
-> (JNullable json a -> JNullable json a -> Bool)
-> Eq (JNullable json a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (json :: k -> *) (a :: k).
Eq (json a) =>
JNullable json a -> JNullable json a -> Bool
/= :: JNullable json a -> JNullable json a -> Bool
$c/= :: forall k (json :: k -> *) (a :: k).
Eq (json a) =>
JNullable json a -> JNullable json a -> Bool
== :: JNullable json a -> JNullable json a -> Bool
$c== :: forall k (json :: k -> *) (a :: k).
Eq (json a) =>
JNullable json a -> JNullable json a -> Bool
Eq, Int -> JNullable json a -> ShowS
[JNullable json a] -> ShowS
JNullable json a -> String
(Int -> JNullable json a -> ShowS)
-> (JNullable json a -> String)
-> ([JNullable json a] -> ShowS)
-> Show (JNullable json a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (json :: k -> *) (a :: k).
Show (json a) =>
Int -> JNullable json a -> ShowS
forall k (json :: k -> *) (a :: k).
Show (json a) =>
[JNullable json a] -> ShowS
forall k (json :: k -> *) (a :: k).
Show (json a) =>
JNullable json a -> String
showList :: [JNullable json a] -> ShowS
$cshowList :: forall k (json :: k -> *) (a :: k).
Show (json a) =>
[JNullable json a] -> ShowS
show :: JNullable json a -> String
$cshow :: forall k (json :: k -> *) (a :: k).
Show (json a) =>
JNullable json a -> String
showsPrec :: Int -> JNullable json a -> ShowS
$cshowsPrec :: forall k (json :: k -> *) (a :: k).
Show (json a) =>
Int -> JNullable json a -> ShowS
Show) via json a
  deriving QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr
     ctxt Postgres s (PgSetOf (PgJSONEach (JNullable json Value)))
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (PgSetOf (PgJSONEach Text))
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (PgSetOf PgJSONKey)
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr
     ctxt Postgres s (PgSetOf (PgJSONElement (JNullable json Value)))
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (PgSetOf (PgJSONElement Text))
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s Text
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (JNullable json b)
QExpr Postgres s a -> QAgg Postgres s (JNullable json a)
QExpr Postgres s key
-> QExpr Postgres s value -> QAgg Postgres s (JNullable json a)
(forall ctxt s a.
 QGenExpr ctxt Postgres s (JNullable json a)
 -> QGenExpr
      ctxt Postgres s (PgSetOf (PgJSONEach (JNullable json Value))))
-> (forall ctxt s a.
    QGenExpr ctxt Postgres s (JNullable json a)
    -> QGenExpr ctxt Postgres s (PgSetOf (PgJSONEach Text)))
-> (forall ctxt s a.
    QGenExpr ctxt Postgres s (JNullable json a)
    -> QGenExpr ctxt Postgres s (PgSetOf PgJSONKey))
-> (forall ctxt s a.
    QGenExpr ctxt Postgres s (JNullable json a)
    -> QGenExpr
         ctxt Postgres s (PgSetOf (PgJSONElement (JNullable json Value))))
-> (forall ctxt s a.
    QGenExpr ctxt Postgres s (JNullable json a)
    -> QGenExpr ctxt Postgres s (PgSetOf (PgJSONElement Text)))
-> (forall ctxt s a.
    QGenExpr ctxt Postgres s (JNullable json a)
    -> QGenExpr ctxt Postgres s Text)
-> (forall ctxt s a b.
    QGenExpr ctxt Postgres s (JNullable json a)
    -> QGenExpr ctxt Postgres s (JNullable json b))
-> (forall s a.
    QExpr Postgres s a -> QAgg Postgres s (JNullable json a))
-> (forall s key value a.
    QExpr Postgres s key
    -> QExpr Postgres s value -> QAgg Postgres s (JNullable json a))
-> IsPgJSON (JNullable json)
forall s a.
QExpr Postgres s a -> QAgg Postgres s (JNullable json a)
forall ctxt s a.
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s Text
forall ctxt s a.
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (PgSetOf (PgJSONEach Text))
forall ctxt s a.
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr
     ctxt Postgres s (PgSetOf (PgJSONEach (JNullable json Value)))
forall ctxt s a.
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (PgSetOf PgJSONKey)
forall ctxt s a.
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (PgSetOf (PgJSONElement Text))
forall ctxt s a.
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr
     ctxt Postgres s (PgSetOf (PgJSONElement (JNullable json Value)))
forall ctxt s a b.
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (JNullable json b)
forall s key value a.
QExpr Postgres s key
-> QExpr Postgres s value -> QAgg Postgres s (JNullable json a)
forall (json :: * -> *) s a.
IsPgJSON json =>
QExpr Postgres s a -> QAgg Postgres s (JNullable json a)
forall (json :: * -> *) ctxt s a.
IsPgJSON json =>
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s Text
forall (json :: * -> *) ctxt s a.
IsPgJSON json =>
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (PgSetOf (PgJSONEach Text))
forall (json :: * -> *) ctxt s a.
IsPgJSON json =>
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr
     ctxt Postgres s (PgSetOf (PgJSONEach (JNullable json Value)))
forall (json :: * -> *) ctxt s a.
IsPgJSON json =>
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (PgSetOf PgJSONKey)
forall (json :: * -> *) ctxt s a.
IsPgJSON json =>
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (PgSetOf (PgJSONElement Text))
forall (json :: * -> *) ctxt s a.
IsPgJSON json =>
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr
     ctxt Postgres s (PgSetOf (PgJSONElement (JNullable json Value)))
forall (json :: * -> *) ctxt s a b.
IsPgJSON json =>
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (JNullable json b)
forall (json :: * -> *) s key value a.
IsPgJSON json =>
QExpr Postgres s key
-> QExpr Postgres s value -> QAgg Postgres s (JNullable json a)
forall (json :: * -> *).
(forall ctxt s a.
 QGenExpr ctxt Postgres s (json a)
 -> QGenExpr ctxt Postgres s (PgSetOf (PgJSONEach (json Value))))
-> (forall ctxt s a.
    QGenExpr ctxt Postgres s (json a)
    -> QGenExpr ctxt Postgres s (PgSetOf (PgJSONEach Text)))
-> (forall ctxt s a.
    QGenExpr ctxt Postgres s (json a)
    -> QGenExpr ctxt Postgres s (PgSetOf PgJSONKey))
-> (forall ctxt s a.
    QGenExpr ctxt Postgres s (json a)
    -> QGenExpr ctxt Postgres s (PgSetOf (PgJSONElement (json Value))))
-> (forall ctxt s a.
    QGenExpr ctxt Postgres s (json a)
    -> QGenExpr ctxt Postgres s (PgSetOf (PgJSONElement Text)))
-> (forall ctxt s a.
    QGenExpr ctxt Postgres s (json a) -> QGenExpr ctxt Postgres s Text)
-> (forall ctxt s a b.
    QGenExpr ctxt Postgres s (json a)
    -> QGenExpr ctxt Postgres s (json b))
-> (forall s a. QExpr Postgres s a -> QAgg Postgres s (json a))
-> (forall s key value a.
    QExpr Postgres s key
    -> QExpr Postgres s value -> QAgg Postgres s (json a))
-> IsPgJSON json
pgJsonObjectAgg :: QExpr Postgres s key
-> QExpr Postgres s value -> QAgg Postgres s (JNullable json a)
$cpgJsonObjectAgg :: forall (json :: * -> *) s key value a.
IsPgJSON json =>
QExpr Postgres s key
-> QExpr Postgres s value -> QAgg Postgres s (JNullable json a)
pgJsonAgg :: QExpr Postgres s a -> QAgg Postgres s (JNullable json a)
$cpgJsonAgg :: forall (json :: * -> *) s a.
IsPgJSON json =>
QExpr Postgres s a -> QAgg Postgres s (JNullable json a)
pgJsonStripNulls :: QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (JNullable json b)
$cpgJsonStripNulls :: forall (json :: * -> *) ctxt s a b.
IsPgJSON json =>
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (JNullable json b)
pgJsonTypeOf :: QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s Text
$cpgJsonTypeOf :: forall (json :: * -> *) ctxt s a.
IsPgJSON json =>
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s Text
pgJsonArrayElementsText :: QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (PgSetOf (PgJSONElement Text))
$cpgJsonArrayElementsText :: forall (json :: * -> *) ctxt s a.
IsPgJSON json =>
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (PgSetOf (PgJSONElement Text))
pgJsonArrayElements :: QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr
     ctxt Postgres s (PgSetOf (PgJSONElement (JNullable json Value)))
$cpgJsonArrayElements :: forall (json :: * -> *) ctxt s a.
IsPgJSON json =>
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr
     ctxt Postgres s (PgSetOf (PgJSONElement (JNullable json Value)))
pgJsonKeys :: QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (PgSetOf PgJSONKey)
$cpgJsonKeys :: forall (json :: * -> *) ctxt s a.
IsPgJSON json =>
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (PgSetOf PgJSONKey)
pgJsonEachText :: QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (PgSetOf (PgJSONEach Text))
$cpgJsonEachText :: forall (json :: * -> *) ctxt s a.
IsPgJSON json =>
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr ctxt Postgres s (PgSetOf (PgJSONEach Text))
pgJsonEach :: QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr
     ctxt Postgres s (PgSetOf (PgJSONEach (JNullable json Value)))
$cpgJsonEach :: forall (json :: * -> *) ctxt s a.
IsPgJSON json =>
QGenExpr ctxt Postgres s (JNullable json a)
-> QGenExpr
     ctxt Postgres s (PgSetOf (PgJSONEach (JNullable json Value)))
B.IsPgJSON via json

deriving via (json a :: Type) instance (B.HasSqlValueSyntax syn (json a))
  => B.HasSqlValueSyntax syn (JNullable json a)

instance ( Pg.FromField (json a :: Type)
         , B.Typeable (a :: Type)
         , B.Typeable json
         )
  => B.FromBackendRow B.Postgres (JNullable json a)

instance Pg.FromField (json a) => Pg.FromField (JNullable json a) where
  fromField :: FieldParser (JNullable json a)
fromField Field
f Maybe ByteString
mbBs = json a -> JNullable json a
forall k (json :: k -> *) (a :: k). json a -> JNullable json a
JNullable
                 (json a -> JNullable json a)
-> Conversion (json a) -> Conversion (JNullable json a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldParser (json a)
forall a. FromField a => FieldParser a
Pg.fromField Field
f (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"null" Maybe ByteString
mbBs)

--------------------------------------------------------------------------------
-- Schema DataTypes
--------------------------------------------------------------------------------

-- | Declares a nullable @PgJSONB@ field in a migration schema
nullableJsonb :: forall a. (Aeson.ToJSON a, Aeson.FromJSON a)
              => B.DataType B.Postgres (JNullable B.PgJSONB a)
nullableJsonb :: DataType Postgres (JNullable PgJSONB a)
nullableJsonb = DataType Postgres (PgJSONB a)
-> DataType Postgres (JNullable PgJSONB a)
coerce (DataType Postgres (PgJSONB a)
forall a. (ToJSON a, FromJSON a) => DataType Postgres (PgJSONB a)
B.jsonb :: B.DataType B.Postgres (B.PgJSONB a))

-- | Declares a nullable @PgJSON@ field in a migration schema
nullableJson :: forall a. (Aeson.ToJSON a, Aeson.FromJSON a)
             => B.DataType B.Postgres (JNullable B.PgJSON a)
nullableJson :: DataType Postgres (JNullable PgJSON a)
nullableJson = DataType Postgres (PgJSON a)
-> DataType Postgres (JNullable PgJSON a)
coerce (DataType Postgres (PgJSON a)
forall a. (ToJSON a, FromJSON a) => DataType Postgres (PgJSON a)
B.json :: B.DataType B.Postgres (B.PgJSON a))