{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Database.Esqueleto.PostgreSQL.JSON.Instances where
import Data.Aeson (FromJSON(..), ToJSON(..), encode, eitherDecodeStrict)
import Data.Bifunctor (first)
import qualified Data.ByteString.Lazy as BSL (toStrict)
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text as T (concat, pack)
import qualified Data.Text.Encoding as TE (decodeUtf8, encodeUtf8)
import Database.Esqueleto (Value, just, val)
import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.Sql (SqlExpr)
import GHC.Generics (Generic)
newtype JSONB a = JSONB { unJSONB :: a }
deriving
( Generic
, FromJSON
, ToJSON
, Eq
, Foldable
, Functor
, Ord
, Read
, Show
, Traversable
)
type JSONBExpr a = SqlExpr (Value (Maybe (JSONB a)))
jsonbVal :: (FromJSON a, ToJSON a) => a -> JSONBExpr a
jsonbVal = just . val . JSONB
data JSONAccessor = JSONIndex Int
| JSONKey Text
deriving (Generic, Eq, Show)
instance Num JSONAccessor where
fromInteger = JSONIndex . fromInteger
negate (JSONIndex i) = JSONIndex $ negate i
negate (JSONKey _) = error "Can not negate a JSONKey"
(+) = numErr
(-) = numErr
(*) = numErr
abs = numErr
signum = numErr
numErr :: a
numErr = error "Do not use 'Num' methods on JSONAccessors"
instance IsString JSONAccessor where
fromString = JSONKey . T.pack
instance (FromJSON a, ToJSON a) => PersistField (JSONB a) where
toPersistValue = PersistDbSpecific . BSL.toStrict . encode . unJSONB
fromPersistValue pVal = fmap JSONB $ case pVal of
PersistByteString bs -> first (badParse $ TE.decodeUtf8 bs) $ eitherDecodeStrict bs
PersistText t -> first (badParse t) $ eitherDecodeStrict (TE.encodeUtf8 t)
x -> Left $ fromPersistValueError "string or bytea" x
instance (FromJSON a, ToJSON a) => PersistFieldSql (JSONB a) where
sqlType _ = SqlOther "JSONB"
badParse :: Text -> String -> Text
badParse t = fromPersistValueParseError t . T.pack
fromPersistValueError
:: Text
-> PersistValue
-> Text
fromPersistValueError databaseType received = T.concat
[ "Failed to parse Haskell newtype `JSONB a`; "
, "expected ", databaseType
, " from database, but received: ", T.pack (show received)
, ". Potential solution: Check that your database schema matches your Persistent model definitions."
]
fromPersistValueParseError
:: Text
-> Text
-> Text
fromPersistValueParseError received err = T.concat
[ "Failed to parse Haskell type `JSONB a`, "
, "but received ", received
, " | with error: ", err
]