mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-16 09:51:59 +03:00
4c016b4c42
- Remove a few unnecessary helper functions - Delete kind annotations - Bring GHC warnings and language extensions more in line with those of the `graphql-engine` library - Constrain unconstrained dependency on `hasql-pool` PR-URL: https://github.com/hasura/graphql-engine-mono/pull/6251 GitOrigin-RevId: 10c2530f007f70cf1464cec36566ee2264589881
100 lines
2.8 KiB
Haskell
100 lines
2.8 KiB
Haskell
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# OPTIONS_GHC -Wno-unused-imports -Wno-orphans -Wno-name-shadowing #-}
|
|
|
|
module Jsonb (specJsonb) where
|
|
|
|
import Control.Monad.Except
|
|
import Control.Monad.Identity
|
|
import Control.Monad.Reader
|
|
import Data.Aeson qualified as J
|
|
import Data.ByteString qualified as BS
|
|
import Data.String
|
|
import Database.PG.Query
|
|
import Database.PG.Query.Connection
|
|
import Database.PostgreSQL.LibPQ.Internal
|
|
import GHC.Generics
|
|
import System.Environment qualified as Env
|
|
import Test.Hspec
|
|
import Prelude
|
|
|
|
newtype TestValue = TestValue {hey :: Int}
|
|
deriving stock (Show, Generic)
|
|
|
|
instance J.FromJSON TestValue
|
|
|
|
instance Show (ViaJSON TestValue) where
|
|
show (ViaJSON tv) = show tv
|
|
|
|
getPgUri :: (MonadIO m) => m BS.ByteString
|
|
getPgUri = liftIO $ fromString <$> Env.getEnv "DATABASE_URL"
|
|
|
|
getPostgresConnect :: (MonadIO m) => m ConnInfo
|
|
getPostgresConnect = do
|
|
dbUri <- getPgUri
|
|
pure $
|
|
defaultConnInfo
|
|
{ ciDetails = CDDatabaseURI dbUri
|
|
}
|
|
|
|
specJsonb :: Spec
|
|
specJsonb = do
|
|
describe "Decoding JSON and JSONB" $ do
|
|
it "Querying 'json' from PostgreSQL succeeds" $ do
|
|
pg <- getPostgresConnect
|
|
result <-
|
|
runTxT
|
|
pg
|
|
(rawQE show "select '{\"hey\":42}'::json" [] False)
|
|
|
|
result `shouldSatisfy` \case
|
|
(Right (SingleRow (Identity (_ :: BS.ByteString)))) -> True
|
|
Left e -> error e
|
|
|
|
it "Querying 'jsonb' from PostgreSQL succeeds" $ do
|
|
pg <- getPostgresConnect
|
|
result <-
|
|
runTxT
|
|
pg
|
|
(rawQE show "select '{\"hey\":42}'::jsonb" [] False)
|
|
|
|
result `shouldSatisfy` \case
|
|
Right (SingleRow (Identity (_ :: BS.ByteString))) -> True
|
|
Left e -> error e
|
|
|
|
it "Querying 'json' from PostgreSQL into ViaJSON type succeeds" $ do
|
|
pg <- getPostgresConnect
|
|
result <-
|
|
runTxT
|
|
pg
|
|
(rawQE show "select '{\"hey\":42}'::json" [] False)
|
|
|
|
result `shouldSatisfy` \case
|
|
Right (SingleRow (Identity (ViaJSON (_ :: TestValue)))) -> True
|
|
Left e -> error e
|
|
|
|
it "Querying 'jsonb' from PostgreSQL into ViaJSON type succeeds" $ do
|
|
pg <- getPostgresConnect
|
|
result <-
|
|
runTxT
|
|
pg
|
|
(rawQE show "select '{\"hey\":42}'::jsonb" [] False)
|
|
|
|
result `shouldSatisfy` \case
|
|
Right (SingleRow (Identity (ViaJSON (_ :: TestValue)))) -> True
|
|
Left e -> error e
|
|
|
|
instance FromPGConnErr String where
|
|
fromPGConnErr = show
|
|
|
|
runTxT :: forall a. ConnInfo -> TxET String IO a -> IO (Either String a)
|
|
runTxT conn q = do
|
|
pool <- initPGPool conn defaultConnParams (const (return ()))
|
|
x <- runExceptT $ runTx' pool q
|
|
destroyPGPool pool
|
|
pure x
|