a452946f58
* added PostgreSQL.JSON module * finished adding all JSON operators * cleanup * half way through writing tests * final tweaks to comments * finished with JSON tests * upped persistent dependency to 2.10.0 because of PersistArray data constructor addition needed for JSON operators * noticed the minus operator with text[] as right operand was only added in PSQL v10, added function and adjusted types/tests * adjusted yaml configs for updated dependencies and PSQL v10 in Travis * try to get PostgreSQL 10 running * use @since notation * removed postgresql from 'services' field * and one more time, with FEELING! (and postgresql-10) * foo * PSQL 10 runs on 5433, it seems? reverting .travis.yml changes and setting test conn to port 5433 * of course I forget to add the PORT env > .< * doop-dee-doo * herp-a-derp * last commit (hopefully) * also have more recent dependencies in the 'compiler should error' tests * why does it feel like this'll go on for a while still? * copied some extra-deps from the persistent ymls * aaaaand we're done... right? * added persistent-postgresql to the dependencies and used its instances for Aeson.Value * small comment fix * moved the instances to their own module, this way they're optional to use if you don't use persistent-postgresql * use port 5432, like a normal PostgreSQL! * added JSONB newtype with instances, instead of orphaning Aeson.Value * reworked everything to use the JSONB newtype. And adjusted most comments to reflect the change * fixed all the tests (just making it compile again) * that's right, Travis' PSQL v10 NEEEEDS it to be port 5433... for some reason * update on the haddockumentation * added JSONAccessor data type for easier usage of certain operators * Also add to changelog.md * JSONExpr -> JSONBExpr * this damn PGPORT is really irritating
121 lines
3.7 KiB
Haskell
121 lines
3.7 KiB
Haskell
{-# 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 wrapper around any type with a JSON representation.
|
|
--
|
|
-- @since 3.1.0
|
|
newtype JSONB a = JSONB { unJSONB :: a }
|
|
deriving
|
|
( Generic
|
|
, FromJSON
|
|
, ToJSON
|
|
, Eq
|
|
, Foldable
|
|
, Functor
|
|
, Ord
|
|
, Read
|
|
, Show
|
|
, Traversable
|
|
)
|
|
|
|
-- | 'SqlExpr' of a NULL-able 'JSONB' value. Hence the 'Maybe'.
|
|
--
|
|
-- Note: NULL here is a PostgreSQL NULL, not a JSON 'null'
|
|
type JSONBExpr a = SqlExpr (Value (Maybe (JSONB a)))
|
|
|
|
-- | Convenience function to lift a regular value into
|
|
-- a 'JSONB' expression.
|
|
jsonbVal :: (FromJSON a, ToJSON a) => a -> JSONBExpr a
|
|
jsonbVal = just . val . JSONB
|
|
|
|
-- | Used with certain JSON operators.
|
|
--
|
|
-- This data type has 'Num' and 'IsString' instances
|
|
-- for ease of use by using integer and string literals.
|
|
--
|
|
-- >>> 3 :: JSONAccessor
|
|
-- JSONIndex 3
|
|
-- >>> -3 :: JSONAccessor
|
|
-- JSONIndex -3
|
|
--
|
|
-- >>> "name" :: JSONAccessor
|
|
-- JSONKey "name"
|
|
--
|
|
-- NOTE: DO NOT USE ANY OF THE 'Num' METHODS ON THIS TYPE!
|
|
data JSONAccessor = JSONIndex Int
|
|
| JSONKey Text
|
|
deriving (Generic, Eq, Show)
|
|
|
|
-- | I repeat, DO NOT use any method other than 'fromInteger'!
|
|
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
|
|
|
|
-- | @since 3.1.0
|
|
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
|
|
|
|
-- | jsonb
|
|
--
|
|
-- @since 3.1.0
|
|
instance (FromJSON a, ToJSON a) => PersistFieldSql (JSONB a) where
|
|
sqlType _ = SqlOther "JSONB"
|
|
|
|
badParse :: Text -> String -> Text
|
|
badParse t = fromPersistValueParseError t . T.pack
|
|
|
|
fromPersistValueError
|
|
:: Text -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int".
|
|
-> PersistValue -- ^ Incorrect value
|
|
-> Text -- ^ Error message
|
|
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 -- ^ Received value
|
|
-> Text -- ^ Additional error
|
|
-> Text -- ^ Error message
|
|
fromPersistValueParseError received err = T.concat
|
|
[ "Failed to parse Haskell type `JSONB a`, "
|
|
, "but received ", received
|
|
, " | with error: ", err
|
|
]
|