mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-14 17:02:49 +03:00
f48c882521
This abstracts `CircularT`'s test cases to work against "any" memoizer, and then runs them against `MemoizeT` as well. Surprisingly (or not), this works without issue; `MemoizeT` passes all tests with a couple of extra instances. PR-URL: https://github.com/hasura/graphql-engine-mono/pull/5780 GitOrigin-RevId: 461880caf9220dc3f52d622a22e8b8bcd594e404
41 lines
1.2 KiB
Haskell
41 lines
1.2 KiB
Haskell
module Control.Monad.TimeLimit
|
|
( runWithTimeLimit,
|
|
succeedsWithinTimeLimit,
|
|
)
|
|
where
|
|
|
|
import Control.Concurrent (newEmptyMVar, putMVar, tryTakeMVar)
|
|
import Control.Concurrent.Async (async)
|
|
import Control.Concurrent.Async qualified as Async
|
|
import Control.Concurrent.Extended (sleep)
|
|
import Hasura.Prelude
|
|
|
|
-- | Runs an action with a time limit of approximately 0.1s.
|
|
-- If the time taken to perform the action exceeds this limit,
|
|
-- it returns 'Nothing'.
|
|
runWithTimeLimit :: MonadIO m => IO a -> m (Maybe a)
|
|
runWithTimeLimit action = liftIO do
|
|
var <- newEmptyMVar
|
|
thread <- async do
|
|
value <- action
|
|
putMVar var $! value
|
|
result <-
|
|
foldr1 continueOnFail $ replicate 10 do
|
|
sleep 0.01
|
|
tryTakeMVar var
|
|
Async.cancel thread
|
|
pure result
|
|
where
|
|
continueOnFail step nextStep =
|
|
step >>= \case
|
|
Nothing -> nextStep
|
|
Just res -> pure (Just res)
|
|
|
|
-- | Runs an action with a time limit of approximately 0.1s.
|
|
-- If the time taken to perform the action exceeds this limit,
|
|
-- it fails.
|
|
succeedsWithinTimeLimit :: (MonadIO m, MonadFail m) => IO a -> m a
|
|
succeedsWithinTimeLimit action =
|
|
runWithTimeLimit action
|
|
`onNothingM` fail "failed to compute in reasonable time"
|