{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds #-}
--------------------------------------------------------------------------------
-- |
-- Module      : Typson.Selda
-- Description : Provides the Selda 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.Selda
  ( jsonPath
  , Json(..)
  ) where

import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy as BSL
import           Data.List (foldl')
import qualified Data.List.NonEmpty as NE
import           Data.Maybe (fromMaybe)
import           Data.String (fromString)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import           Data.Typeable (Typeable)
import qualified Database.Selda as S
import qualified Database.Selda.Backend as S
import           Database.Selda.JSON ()
import qualified Database.Selda.PostgreSQL as S
import qualified Database.Selda.Unsafe as S

import           Typson

-- | Use a type-safe JSON path as part of a query.
--
-- @
-- query $ jsonPath (Proxy @("foo" :-> "bar")) fieldSchemaJ
--       . (! #field)
--     \<$> select someTable
-- @
jsonPath :: ( TypeAtPath o tree path ~ target
            , ReflectPath path
            )
         => proxy (path :: k) -- ^ A path proxy
         -> ObjectTree tree o -- ^ Typson schema
         -> S.Col S.PG (Json o) -- ^ Column selector
         -> S.Col S.PG (Json target)
jsonPath :: proxy path
-> ObjectTree tree o -> Col PG (Json o) -> Col PG (Json target)
jsonPath path :: proxy path
path _ col :: Col PG (Json o)
col =
  case proxy path -> NonEmpty PathComponent
forall k (path :: k) (proxy :: k -> *).
ReflectPath path =>
proxy path -> NonEmpty PathComponent
reflectPath proxy path
path of
    p :: PathComponent
p NE.:| ps :: [PathComponent]
ps -> (Col PG (Json target) -> PathComponent -> Col PG (Json target))
-> Col PG (Json target) -> [PathComponent] -> Col PG (Json target)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Col PG (Json target) -> PathComponent -> Col PG (Json target)
forall a c. Col PG a -> PathComponent -> Col PG c
buildPath (Col PG (Json o) -> PathComponent -> Col PG (Json target)
forall a c. Col PG a -> PathComponent -> Col PG c
buildPath Col PG (Json o)
col PathComponent
p) [PathComponent]
ps
  where
    buildPath :: Col PG a -> PathComponent -> Col PG c
buildPath c :: Col PG a
c (Key k :: String
k) = Text -> Col PG a -> Col PG Text -> Col PG c
forall s a b c. Text -> Col s a -> Col s b -> Col s c
S.operator "->" Col PG a
c (String -> Col PG Text
forall a. IsString a => String -> a
fromString String
k :: S.Col S.PG T.Text)
    buildPath c :: Col PG a
c (Idx i :: Integer
i) = Text -> Col PG a -> Col PG Int -> Col PG c
forall s a b c. Text -> Col s a -> Col s b -> Col s c
S.operator "->" Col PG a
c (Text -> Col PG Int
forall a s. SqlType a => Text -> Col s a
S.rawExp (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
i) :: S.Col S.PG Int)
    -- had to resort to `rawExp` here because selda uses bigint for Int which
    -- does not work with the -> operator

--------------------------------------------------------------------------------
-- Json Serialization Wrapper
--------------------------------------------------------------------------------

-- | Use this wrapper on fields that are serialized as JSON in the database.
-- It's deserialization treats SQL @NULL@ as JSON @null@.
newtype Json a =
  Json
    { Json a -> a
unJson :: a
    } deriving (Int -> Json a -> ShowS
[Json a] -> ShowS
Json a -> String
(Int -> Json a -> ShowS)
-> (Json a -> String) -> ([Json a] -> ShowS) -> Show (Json a)
forall a. Show a => Int -> Json a -> ShowS
forall a. Show a => [Json a] -> ShowS
forall a. Show a => Json a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Json a] -> ShowS
$cshowList :: forall a. Show a => [Json a] -> ShowS
show :: Json a -> String
$cshow :: forall a. Show a => Json a -> String
showsPrec :: Int -> Json a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Json a -> ShowS
Show, Json a -> Json a -> Bool
(Json a -> Json a -> Bool)
-> (Json a -> Json a -> Bool) -> Eq (Json a)
forall a. Eq a => Json a -> Json a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Json a -> Json a -> Bool
$c/= :: forall a. Eq a => Json a -> Json a -> Bool
== :: Json a -> Json a -> Bool
$c== :: forall a. Eq a => Json a -> Json a -> Bool
Eq, Eq (Json a)
Eq (Json a) =>
(Json a -> Json a -> Ordering)
-> (Json a -> Json a -> Bool)
-> (Json a -> Json a -> Bool)
-> (Json a -> Json a -> Bool)
-> (Json a -> Json a -> Bool)
-> (Json a -> Json a -> Json a)
-> (Json a -> Json a -> Json a)
-> Ord (Json a)
Json a -> Json a -> Bool
Json a -> Json a -> Ordering
Json a -> Json a -> 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 a. Ord a => Eq (Json a)
forall a. Ord a => Json a -> Json a -> Bool
forall a. Ord a => Json a -> Json a -> Ordering
forall a. Ord a => Json a -> Json a -> Json a
min :: Json a -> Json a -> Json a
$cmin :: forall a. Ord a => Json a -> Json a -> Json a
max :: Json a -> Json a -> Json a
$cmax :: forall a. Ord a => Json a -> Json a -> Json a
>= :: Json a -> Json a -> Bool
$c>= :: forall a. Ord a => Json a -> Json a -> Bool
> :: Json a -> Json a -> Bool
$c> :: forall a. Ord a => Json a -> Json a -> Bool
<= :: Json a -> Json a -> Bool
$c<= :: forall a. Ord a => Json a -> Json a -> Bool
< :: Json a -> Json a -> Bool
$c< :: forall a. Ord a => Json a -> Json a -> Bool
compare :: Json a -> Json a -> Ordering
$ccompare :: forall a. Ord a => Json a -> Json a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Json a)
Ord)
      deriving newtype ([Json a] -> Encoding
[Json a] -> Value
Json a -> Encoding
Json a -> Value
(Json a -> Value)
-> (Json a -> Encoding)
-> ([Json a] -> Value)
-> ([Json a] -> Encoding)
-> ToJSON (Json a)
forall a. ToJSON a => [Json a] -> Encoding
forall a. ToJSON a => [Json a] -> Value
forall a. ToJSON a => Json a -> Encoding
forall a. ToJSON a => Json a -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Json a] -> Encoding
$ctoEncodingList :: forall a. ToJSON a => [Json a] -> Encoding
toJSONList :: [Json a] -> Value
$ctoJSONList :: forall a. ToJSON a => [Json a] -> Value
toEncoding :: Json a -> Encoding
$ctoEncoding :: forall a. ToJSON a => Json a -> Encoding
toJSON :: Json a -> Value
$ctoJSON :: forall a. ToJSON a => Json a -> Value
Aeson.ToJSON, Value -> Parser [Json a]
Value -> Parser (Json a)
(Value -> Parser (Json a))
-> (Value -> Parser [Json a]) -> FromJSON (Json a)
forall a. FromJSON a => Value -> Parser [Json a]
forall a. FromJSON a => Value -> Parser (Json a)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Json a]
$cparseJSONList :: forall a. FromJSON a => Value -> Parser [Json a]
parseJSON :: Value -> Parser (Json a)
$cparseJSON :: forall a. FromJSON a => Value -> Parser (Json a)
Aeson.FromJSON)

decodeError :: Show a => a -> b
decodeError :: a -> b
decodeError x :: a
x = String -> b
forall a. HasCallStack => String -> a
error (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ "fromSql: json column with invalid json: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x

typeError :: Show a => a -> b
typeError :: a -> b
typeError x :: a
x = String -> b
forall a. HasCallStack => String -> a
error (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ "fromSql: json column with non-text value: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x

instance (Typeable a, Aeson.ToJSON a, Aeson.FromJSON a, Show a) => S.SqlType (Json a) where
  mkLit :: Json a -> Lit (Json a)
mkLit j :: Json a
j =
    case Value -> Lit Value
forall a. SqlType a => a -> Lit a
S.mkLit (Value -> Lit Value) -> Value -> Lit Value
forall a b. (a -> b) -> a -> b
$ Json a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON Json a
j of
      S.LCustom rep :: SqlTypeRep
rep l :: Lit a1
l -> SqlTypeRep -> Lit a1 -> Lit (Json a)
forall a1 a. SqlTypeRep -> Lit a1 -> Lit a
S.LCustom SqlTypeRep
rep Lit a1
l
  sqlType :: Proxy (Json a) -> SqlTypeRep
sqlType _ = SqlTypeRep
S.TJSON
  defaultValue :: Lit (Json a)
defaultValue =
    case Value -> Lit Value
forall a. SqlType a => a -> Lit a
S.mkLit Value
Aeson.Null of
      S.LCustom rep :: SqlTypeRep
rep l :: Lit a1
l -> SqlTypeRep -> Lit a1 -> Lit (Json a)
forall a1 a. SqlTypeRep -> Lit a1 -> Lit a
S.LCustom SqlTypeRep
rep Lit a1
l
  fromSql :: SqlValue -> Json a
fromSql (S.SqlBlob t :: ByteString
t) =
    Json a -> Maybe (Json a) -> Json a
forall a. a -> Maybe a -> a
fromMaybe (ByteString -> Json a
forall a b. Show a => a -> b
decodeError ByteString
t) (ByteString -> Maybe (Json a)
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode' (ByteString -> Maybe (Json a)) -> ByteString -> Maybe (Json a)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.fromStrict ByteString
t)
  fromSql (S.SqlString t :: Text
t) =
    Json a -> Maybe (Json a) -> Json a
forall a. a -> Maybe a -> a
fromMaybe (Text -> Json a
forall a b. Show a => a -> b
decodeError Text
t) (ByteString -> Maybe (Json a)
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode' (ByteString -> Maybe (Json a))
-> (ByteString -> ByteString) -> ByteString -> Maybe (Json a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict (ByteString -> Maybe (Json a)) -> ByteString -> Maybe (Json a)
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t)
  fromSql S.SqlNull =
    case Value -> Result (Json a)
forall a. FromJSON a => Value -> Result a
Aeson.fromJSON Value
Aeson.Null of
      Aeson.Success a :: Json a
a -> Json a
a
      _ -> SqlValue -> Json a
forall a b. Show a => a -> b
typeError SqlValue
S.SqlNull
  fromSql x :: SqlValue
x = SqlValue -> Json a
forall a b. Show a => a -> b
typeError SqlValue
x