mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-24 07:52:14 +03:00
be67b0db59
This fixes the simple HLint warnings, and adds a few suppressions to avoid noise. The suppressions don't really solve the problems, but I think the warnings here are quite benign and I'm uncomfortable with how likely I would be to introduce a bug during refactoring. In the case of _pg-client_ and _resource-pool_, we can't use the recommended functions anyway, and there doesn't seem to be a way to tell HLint to ignore entire packages. I have updated the `make` targets to only fail if errors or warnings are found, not suggestions. This brings it in line with the CI job. PR-URL: https://github.com/hasura/graphql-engine-mono/pull/8910 GitOrigin-RevId: 596277b4ae5833876fc3f43875208c1279518a59
144 lines
4.2 KiB
Haskell
144 lines
4.2 KiB
Haskell
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE NumericUnderscores #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
|
|
|
{-# HLINT ignore "Use withAsync" #-}
|
|
{-# 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
|
|
|
|
-------------------------------------------------------------------------------
|
|
|
|
{-# ANN module ("HLint: ignore avoid Control.Concurrent.forkIO" :: String) #-}
|
|
|
|
{-# ANN module ("HLint: ignore avoid Control.Concurrent.threadDelay" :: String) #-}
|
|
|
|
{- 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"
|