mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-18 13:02:11 +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
139 lines
4.0 KiB
Haskell
139 lines
4.0 KiB
Haskell
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE NumericUnderscores #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
|
|
|
{-# HLINT ignore "Use sleep" #-}
|
|
|
|
module Main (main) where
|
|
|
|
-------------------------------------------------------------------------------
|
|
|
|
import Control.Concurrent (forkIO, threadDelay)
|
|
import Control.Monad.Trans.Class (MonadTrans (lift))
|
|
import Control.Monad.Trans.Except (runExceptT)
|
|
import Data.ByteString.Char8 qualified as BS
|
|
import Database.PG.Query
|
|
import Interrupt (specInterrupt)
|
|
import Jsonb (specJsonb)
|
|
import System.Environment qualified as Env
|
|
import Test.Hspec (describe, hspec, it, shouldReturn)
|
|
import Timeout (specTimeout)
|
|
import Prelude
|
|
|
|
-------------------------------------------------------------------------------
|
|
|
|
{- Note [Running tests]
|
|
~~~~~~~~~~~~~~~~~~~~~~~
|
|
The tests in this module expect a postgres instance running. No setup is
|
|
required, these tests do not run any query on the database. The only requirement
|
|
is that the environment variable DATABASE_URL is set such that it is a valid
|
|
connection string to this instance (e.g.
|
|
"postgres://user:pass@127.0.0.1:5432/instance?sslmode=disable").
|
|
|
|
TODO: run these tests as part of CI.
|
|
-}
|
|
|
|
main :: IO ()
|
|
main = hspec $ do
|
|
describe "acquiring connections" do
|
|
it "acquire a single available resource" do
|
|
simpleTest `shouldReturn` Nothing
|
|
it "error when no connections available" do
|
|
noConnectionAvailable `shouldReturn` Nothing
|
|
it "release and acquire works correctly" do
|
|
releaseAndAcquire `shouldReturn` Nothing
|
|
it "release and acquire works correctly" do
|
|
releaseAndAcquireWithTimeout `shouldReturn` Nothing
|
|
it "time out works correctly" do
|
|
releaseAndAcquireWithTimeoutNegative `shouldReturn` Nothing
|
|
specInterrupt
|
|
specTimeout
|
|
specJsonb
|
|
|
|
mkPool :: IO PGPool
|
|
mkPool = do
|
|
dbUri <- BS.pack <$> Env.getEnv "DATABASE_URL"
|
|
initPGPool (connInfo dbUri) connParams logger
|
|
where
|
|
connInfo uri = ConnInfo {ciRetries, ciDetails = mkDetails uri}
|
|
ciRetries = 0
|
|
mkDetails = CDDatabaseURI
|
|
logger = mempty
|
|
connParams = ConnParams 1 1 60 True Nothing (Just 3) False
|
|
|
|
withFreshPool ::
|
|
(FromPGConnErr e) =>
|
|
PGPool ->
|
|
IO a ->
|
|
IO (Either e a)
|
|
withFreshPool pool action =
|
|
runExceptT
|
|
. withConn pool
|
|
. const
|
|
$ lift action
|
|
|
|
err :: Show a => a -> IO (Maybe String)
|
|
err = pure . Just . show
|
|
|
|
nada :: IO ()
|
|
nada = mempty
|
|
|
|
simpleTest :: IO (Maybe String)
|
|
simpleTest = do
|
|
pool <- mkPool
|
|
withFreshPool pool nada >>= \case
|
|
Left (e :: PGExecErr) -> err e
|
|
Right _ -> mempty
|
|
|
|
noConnectionAvailable :: IO (Maybe String)
|
|
noConnectionAvailable = do
|
|
pool <- mkPool
|
|
withFreshPool pool (action pool) >>= \case
|
|
Left (e :: PGExecErr) -> err e
|
|
Right _ -> mempty
|
|
where
|
|
action pool =
|
|
withFreshPool pool nada >>= \case
|
|
Left (_ :: PGExecErr) -> mempty
|
|
Right _ -> err "connection acquisition expected to fail"
|
|
|
|
releaseAndAcquire :: IO (Maybe String)
|
|
releaseAndAcquire = do
|
|
pool <- mkPool
|
|
_ <-
|
|
withFreshPool pool nada >>= \case
|
|
Left (e :: PGExecErr) -> err e
|
|
Right _ -> mempty
|
|
withFreshPool pool nada >>= \case
|
|
Left (e :: PGExecErr) -> err e
|
|
Right _ -> mempty
|
|
|
|
releaseAndAcquireWithTimeout :: IO (Maybe String)
|
|
releaseAndAcquireWithTimeout = do
|
|
pool <- mkPool
|
|
_ <-
|
|
forkIO $
|
|
withFreshPool pool (threadDelay 300_000) >>= \case
|
|
Left (_ :: PGExecErr) -> error "unexpected error when acquiring connections"
|
|
Right _ -> mempty
|
|
threadDelay 100_000
|
|
withFreshPool pool nada >>= \case
|
|
Left (e :: PGExecErr) -> err e
|
|
Right _ -> mempty
|
|
|
|
releaseAndAcquireWithTimeoutNegative :: IO (Maybe String)
|
|
releaseAndAcquireWithTimeoutNegative = do
|
|
pool <- mkPool
|
|
_ <-
|
|
forkIO $
|
|
withFreshPool pool (threadDelay 10_000_000) >>= \case
|
|
Left (_ :: PGExecErr) -> error "unexpected error when acquiring connections"
|
|
Right _ -> mempty
|
|
threadDelay 1_000_000
|
|
withFreshPool pool nada >>= \case
|
|
Left (_ :: PGExecErr) -> mempty
|
|
Right _ -> err "Wat"
|