diff --git a/Haxl/Core.hs b/Haxl/Core.hs --- a/Haxl/Core.hs +++ b/Haxl/Core.hs @@ -26,13 +26,16 @@ -- ** Data fetching and caching dataFetch, uncachedRequest, - cacheRequest, cacheResult, cachedComputation, + cacheRequest, cacheResult, cacheResultWithShow, cachedComputation, dumpCacheAsHaskell, -- ** Memoization memo, memoize, memoize1, memoize2, memoFingerprint, MemoFingerprintKey(..), + -- ** Conditionals + pAnd, pOr, + -- ** Statistics Stats(..), RoundStats(..), @@ -81,7 +84,7 @@ tryTakeResult, -- ** Default fetch implementations - asyncFetch, asyncFetchWithDispatch, + asyncFetch, asyncFetchWithDispatch, asyncFetchAcquireRelease, stubFetch, syncFetch, diff --git a/Haxl/Core/DataCache.hs b/Haxl/Core/DataCache.hs --- a/Haxl/Core/DataCache.hs +++ b/Haxl/Core/DataCache.hs @@ -28,7 +28,7 @@ import Prelude hiding (lookup) import Unsafe.Coerce import qualified Data.HashMap.Strict as HashMap -import Data.Typeable.Internal +import Data.Typeable import Data.Maybe #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) diff --git a/Haxl/Core/Exception.hs b/Haxl/Core/Exception.hs --- a/Haxl/Core/Exception.hs +++ b/Haxl/Core/Exception.hs @@ -5,6 +5,7 @@ -- found in the LICENSE file. An additional grant of patent rights can -- be found in the PATENTS file. +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE StandaloneDeriving #-} @@ -67,10 +68,14 @@ -- * Exception utilities asHaxlException, MiddleException(..), - + rethrowAsyncExceptions, + tryWithRethrow, ) where -import Control.Exception +#if __GLASGOW_HASKELL__ <= 708 +import Control.Applicative ((<$>)) +#endif +import Control.Exception as Exception import Data.Aeson import Data.Binary (Binary) import Data.Typeable @@ -326,3 +331,45 @@ haxl_exception | otherwise = HaxlException Nothing (InternalError (NonHaxlException (textShow e))) + +-- We must be careful about turning IO monad exceptions into Haxl +-- exceptions. An IO monad exception will normally propagate right +-- out of runHaxl and terminate the whole computation, whereas a Haxl +-- exception can get dropped on the floor, if it is on the right of +-- <*> and the left side also throws, for example. So turning an IO +-- monad exception into a Haxl exception is a dangerous thing to do. +-- In particular, we never want to do it for an asynchronous exception +-- (AllocationLimitExceeded, ThreadKilled, etc.), because these are +-- supposed to unconditionally terminate the computation. +-- +-- There are three places where we take an arbitrary IO monad exception and +-- turn it into a Haxl exception: +-- +-- * wrapFetchInCatch. Here we want to propagate a failure of the +-- data source to the callers of the data source, but if the +-- failure came from elsewhere (an asynchronous exception), then we +-- should just propagate it +-- +-- * cacheResult (cache the results of IO operations): again, +-- failures of the IO operation should be visible to the caller as +-- a Haxl exception, but we exclude asynchronous exceptions from +-- this. + +-- * unsafeToHaxlException: assume the caller knows what they're +-- doing, and just wrap all exceptions. +-- +rethrowAsyncExceptions :: SomeException -> IO () +rethrowAsyncExceptions e +#if __GLASGOW_HASKELL__ >= 708 + | Just SomeAsyncException{} <- fromException e = Exception.throw e +#endif +#if __GLASGOW_HASKELL__ >= 710 + | Just AllocationLimitExceeded{} <- fromException e = Exception.throw e + -- AllocationLimitExceeded is not a child of SomeAsyncException, + -- but it should be. +#endif + | otherwise = return () + +tryWithRethrow :: IO a -> IO (Either SomeException a) +tryWithRethrow io = + (Right <$> io) `catch` \e -> do rethrowAsyncExceptions e ; return (Left e) diff --git a/Haxl/Core/Monad.hs b/Haxl/Core/Monad.hs --- a/Haxl/Core/Monad.hs +++ b/Haxl/Core/Monad.hs @@ -51,6 +51,9 @@ -- * Unsafe operations unsafeLiftIO, unsafeToHaxlException, + + -- * Parallel operaitons + pAnd, pOr ) where import Haxl.Core.Types @@ -64,11 +67,7 @@ import qualified Data.Text as Text import qualified Control.Monad.Catch as Catch import Control.Exception (Exception(..), SomeException) -#if __GLASGOW_HASKELL__ >= 708 -import Control.Exception (SomeAsyncException(..)) -#endif #if __GLASGOW_HASKELL__ >= 710 -import Control.Exception (AllocationLimitExceeded(..)) import GHC.Conc (getAllocationCounter, setAllocationCounter) #endif import Control.Monad @@ -299,7 +298,7 @@ n' <- performFetches n env bs traceEventIO "STOP performFetches" when (caching (flags env) == 0) $ - writeIORef (cacheRef env) DataCache.empty + writeIORef (cacheRef env) emptyDataCache go n' env cont traceEventIO "START runHaxl" r <- go 0 env (Cont h) @@ -687,44 +686,6 @@ , " cacheResult on a query that involves a blocking fetch." ] --- We must be careful about turning IO monad exceptions into Haxl --- exceptions. An IO monad exception will normally propagate right --- out of runHaxl and terminate the whole computation, whereas a Haxl --- exception can get dropped on the floor, if it is on the right of --- <*> and the left side also throws, for example. So turning an IO --- monad exception into a Haxl exception is a dangerous thing to do. --- In particular, we never want to do it for an asynchronous exception --- (AllocationLimitExceeded, ThreadKilled, etc.), because these are --- supposed to unconditionally terminate the computation. --- --- There are three places where we take an arbitrary IO monad exception and --- turn it into a Haxl exception: --- --- * wrapFetchInCatch. Here we want to propagate a failure of the --- data source to the callers of the data source, but if the --- failure came from elsewhere (an asynchronous exception), then we --- should just propagate it --- --- * cacheResult (cache the results of IO operations): again, --- failures of the IO operation should be visible to the caller as --- a Haxl exception, but we exclude asynchronous exceptions from --- this. - --- * unsafeToHaxlException: assume the caller knows what they're --- doing, and just wrap all exceptions. --- -rethrowAsyncExceptions :: SomeException -> IO () -rethrowAsyncExceptions e -#if __GLASGOW_HASKELL__ >= 708 - | Just SomeAsyncException{} <- fromException e = Exception.throw e -#endif -#if __GLASGOW_HASKELL__ >= 710 - | Just AllocationLimitExceeded{} <- fromException e = Exception.throw e - -- AllocationLimitExceeded is not a child of SomeAsyncException, - -- but it should be. -#endif - | otherwise = return () - -- | Inserts a request/result pair into the cache. Throws an exception -- if the request has already been issued, either via 'dataFetch' or -- 'cacheRequest'. @@ -860,6 +821,16 @@ SyncFetch (io `Exception.catch` handler) AsyncFetch fio -> AsyncFetch (\io -> fio io `Exception.catch` handler) + -- this might be wrong: if the outer 'fio' throws an exception, + -- then we don't know whether we have executed the inner 'io' or + -- not. If not, then we'll likely get some errors about "did + -- not set result var" later, because we haven't executed some + -- data fetches. But we can't execute 'io' in the handler, + -- because we might have already done it. It isn't possible to + -- do it completely right here, so we have to rely on data + -- sources themselves to catch (synchronous) exceptions. Async + -- exceptions aren't a problem because we're going to rethrow + -- them all the way to runHaxl anyway. where handler :: SomeException -> IO () handler e = do @@ -1210,3 +1181,81 @@ (MemoTbl2 (f, HashMap.insert k1 (HashMap.insert k2 v h2) h1)) runMemo v Just v -> runMemo v + + +-- ----------------------------------------------------------------------------- +-- Parallel operations + +-- Bind more tightly than .&&, .|| +infixr 5 `pAnd` +infixr 4 `pOr` + +-- | Parallel version of '(.||)'. Both arguments are evaluated in +-- parallel, and if either returns 'True' then the other is +-- not evaluated any further. +-- +-- WARNING: exceptions may be unpredictable when using 'pOr'. If one +-- argument returns 'True' before the other completes, then 'pOr' +-- returns 'True' immediately, ignoring a possible exception that +-- the other argument may have produced if it had been allowed to +-- complete. +pOr :: GenHaxl u Bool -> GenHaxl u Bool -> GenHaxl u Bool +GenHaxl a `pOr` GenHaxl b = GenHaxl $ \env ref -> do + ra <- a env ref + case ra of + Done True -> return (Done True) + Done False -> b env ref + Throw _ -> return ra + Blocked a' -> do + rb <- b env ref + case rb of + Done True -> return (Blocked (Cont (return True))) + -- Note [tricky pOr/pAnd] + Done False -> return ra + Throw e -> return (Blocked (Cont (throw e))) + Blocked b' -> return (Blocked (Cont (toHaxl a' `pOr` toHaxl b'))) + +-- | Parallel version of '(.&&)'. Both arguments are evaluated in +-- parallel, and if either returns 'False' then the other is +-- not evaluated any further. +-- +-- WARNING: exceptions may be unpredictable when using 'pAnd'. If one +-- argument returns 'False' before the other completes, then 'pAnd' +-- returns 'False' immediately, ignoring a possible exception that +-- the other argument may have produced if it had been allowed to +-- complete. +pAnd :: GenHaxl u Bool -> GenHaxl u Bool -> GenHaxl u Bool +GenHaxl a `pAnd` GenHaxl b = GenHaxl $ \env ref -> do + ra <- a env ref + case ra of + Done False -> return (Done False) + Done True -> b env ref + Throw _ -> return ra + Blocked a' -> do + rb <- b env ref + case rb of + Done False -> return (Blocked (Cont (return False))) + -- Note [tricky pOr/pAnd] + Done True -> return ra + Throw _ -> return rb + Blocked b' -> return (Blocked (Cont (toHaxl a' `pAnd` toHaxl b'))) + +{- +Note [tricky pOr/pAnd] + +If one branch returns (Done True) and the other returns (Blocked _), +even though we know the result will be True (in the case of pOr), we +must return Blocked. This is because there are data fetches to +perform, and if we don't do this, the cache is left with an empty +ResultVar, and the next fetch for the same request will fail. + +Alternatives: + + * Test for a non-empty RequestStore in runHaxl when we get Done, but + that would penalise every runHaxl. + + * Try to abandon the fetches. This is hard: we've already stored the + requests and a ResultVars in the cache, and we don't know how to + find the right fetches to remove from the cache. Furthermore, we + might have partially computed some memoized computations. +-} diff --git a/Haxl/Core/Types.hs b/Haxl/Core/Types.hs --- a/Haxl/Core/Types.hs +++ b/Haxl/Core/Types.hs @@ -81,6 +81,7 @@ -- * Default fetch implementations asyncFetch, asyncFetchWithDispatch, + asyncFetchAcquireRelease, stubFetch, syncFetch, @@ -109,8 +110,9 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Text (Text, unpack) -import Data.Typeable.Internal +import Data.Typeable +import Haxl.Core.Exception #if __GLASGOW_HASKELL__ < 708 import Haxl.Core.Util (tryReadMVar) #endif @@ -551,6 +553,77 @@ getResults <- mapM (submitFetch service enqueue) requests dispatch service sequence_ getResults + + +{- | +A version of 'asyncFetch' (actually 'asyncFetchWithDispatch') that +handles exceptions correctly. You should use this instead of +'asyncFetch' or 'asyncFetchWithDispatch'. The danger with +'asyncFetch' is that if an exception is thrown by @withService@, the +@inner@ action won't be executed, and we'll drop some data-fetches in +the same round. + +'asyncFetchAcquireRelease' behaves like the following: + +> asyncFetchAcquireRelease acquire release dispatch wait enqueue = +> AsyncFetch $ \inner -> +> bracket acquire release $ \service -> do +> getResults <- mapM (submitFetch service enqueue) requests +> dispatch service +> inner +> wait service +> sequence_ getResults + +except that @inner@ is run even if @acquire@, @enqueue@, or @dispatch@ throws, +/unless/ an async exception is received. +-} + +asyncFetchAcquireRelease + :: IO service + -- ^ Resource acquisition for this datasource + + -> (service -> IO ()) + -- ^ Resource release + + -> (service -> IO ()) + -- ^ Dispatch all the pending requests and wait for the results + + -> (service -> IO ()) + -- ^ Wait for the results + + -> (forall a. service -> request a -> IO (IO (Either SomeException a))) + -- ^ Submits an individual request to the service. + + -> State request + -- ^ Currently unused. + + -> Flags + -- ^ Currently unused. + + -> u + -- ^ Currently unused. + + -> [BlockedFetch request] + -- ^ Requests to submit. + + -> PerformFetch + +asyncFetchAcquireRelease + acquire release dispatch wait enqueue _state _flags _si requests = + AsyncFetch $ \inner -> mask $ \restore -> do + r1 <- tryWithRethrow acquire + case r1 of + Left err -> do restore inner; throwIO (err :: SomeException) + Right service -> do + flip finally (release service) $ restore $ do + r2 <- tryWithRethrow $ do + getResults <- mapM (submitFetch service enqueue) requests + dispatch service + return getResults + inner -- we assume this cannot throw, ensured by performFetches + case r2 of + Left err -> throwIO (err :: SomeException) + Right getResults -> do wait service; sequence_ getResults -- | Used by 'asyncFetch' and 'syncFetch' to retrieve the results of -- requests to a service. diff --git a/Haxl/Prelude.hs b/Haxl/Prelude.hs --- a/Haxl/Prelude.hs +++ b/Haxl/Prelude.hs @@ -52,6 +52,7 @@ (.==), (./=), (.&&), (.||), (.++), pair, + pAnd, pOr, -- * Text things Text, diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,10 @@ +# Changes in version 0.5.1.0 + + * 'pAnd' and 'pOr' were added + * 'asyncFetchAcquireRelease' was added + * 'cacheResultWithShow' was exposed + * GHC 8.2.1 compatibility + # Changes in version 0.5.0.0 * Rename 'Show1' to 'ShowP' ([#62](https://github.com/facebook/Haxl/issues/62)) diff --git a/haxl.cabal b/haxl.cabal --- a/haxl.cabal +++ b/haxl.cabal @@ -1,11 +1,11 @@ name: haxl -version: 0.5.0.0 +version: 0.5.1.0 synopsis: A Haskell library for efficient, concurrent, and concise data access. homepage: https://github.com/facebook/Haxl bug-reports: https://github.com/facebook/Haxl/issues -license: BSD3 -license-file: LICENSE +license: OtherLicense +license-files: LICENSE,PATENTS author: Facebook, Inc. maintainer: The Haxl Team copyright: Copyright (c) 2014-present, Facebook, Inc. @@ -16,7 +16,8 @@ tested-with: GHC==7.8.4, GHC==7.10.3, - GHC==8.0.2 + GHC==8.0.2, + GHC==8.2.1 description: Haxl is a library and EDSL for efficient scheduling of concurrent data @@ -42,10 +43,10 @@ library build-depends: - HUnit >= 1.2 && < 1.6, - aeson >= 0.6 && < 1.2, + HUnit >= 1.2 && < 1.7, + aeson >= 0.6 && < 1.3, base == 4.*, - binary >= 0.7 && < 0.9, + binary >= 0.7 && < 0.10, bytestring >= 0.9 && < 0.11, containers == 0.5.*, deepseq, @@ -54,8 +55,9 @@ ghc-prim, hashable == 1.2.*, pretty == 1.1.*, - text >= 1.1.0.1 && < 1.3, - time >= 1.4 && < 1.8, + -- text 1.2.1.0 required for instance Binary Text + text >= 1.2.1.0 && < 1.3, + time >= 1.4 && < 1.9, transformers, unordered-containers == 0.2.*, vector >= 0.10 && <0.13 @@ -97,6 +99,7 @@ test-framework, test-framework-hunit, text, + time, unordered-containers ghc-options: @@ -113,6 +116,7 @@ other-modules: AdoTests AllTests + BadDataSource BatchTests Bench CoreTests @@ -122,6 +126,7 @@ MemoizationTests MockTAO ProfileTests + TestBadDataSource TestExampleDataSource TestTypes TestUtils diff --git a/tests/AllTests.hs b/tests/AllTests.hs --- a/tests/AllTests.hs +++ b/tests/AllTests.hs @@ -5,13 +5,14 @@ import BatchTests import CoreTests import DataCacheTest -#ifdef HAVE_APPLICATIVEDO +#if __GLASGOW_HASKELL__ >= 801 import AdoTests #endif #if __GLASGOW_HASKELL__ >= 710 import ProfileTests #endif import MemoizationTests +import TestBadDataSource import Test.HUnit @@ -21,11 +22,12 @@ , TestLabel "BatchTests" BatchTests.tests , TestLabel "CoreTests" CoreTests.tests , TestLabel "DataCacheTests" DataCacheTest.tests -#ifdef HAVE_APPLICATIVEDO +#if __GLASGOW_HASKELL__ >= 801 , TestLabel "AdoTests" AdoTests.tests #endif #if __GLASGOW_HASKELL__ >= 710 , TestLabel "ProfileTests" ProfileTests.tests #endif , TestLabel "MemoizationTests" MemoizationTests.tests + , TestLabel "BadDataSourceTests" TestBadDataSource.tests ] diff --git a/tests/BadDataSource.hs b/tests/BadDataSource.hs new file mode 100644 --- /dev/null +++ b/tests/BadDataSource.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} + +-- | A data source that can be made to fail in various ways, for testing + +module BadDataSource ( + -- * initialise the state + State(..), initGlobalState, + + -- * requests for this data source + FailAfter(..), + ) where + +import Haxl.Prelude +import Prelude () + +import Haxl.Core + +import Control.Exception +import Data.Typeable +import Data.Hashable +import Control.Concurrent + +data FailAfter a where + FailAfter :: Int -> FailAfter Int + deriving Typeable + +deriving instance Eq (FailAfter a) +deriving instance Show (FailAfter a) +instance ShowP FailAfter where showp = show + +instance Hashable (FailAfter a) where + hashWithSalt s (FailAfter a) = hashWithSalt s (0::Int,a) + +instance StateKey FailAfter where + data State FailAfter = FailAfterState + { failAcquireDelay :: Int + , failAcquire :: IO () + , failReleaseDelay :: Int + , failRelease :: IO () + , failDispatchDelay :: Int + , failDispatch :: IO () + , failWaitDelay :: Int + , failWait :: IO () + } + +instance DataSourceName FailAfter where + dataSourceName _ = "BadDataSource" + +instance DataSource u FailAfter where + -- I'll define exampleFetch below + fetch state@FailAfterState{..} = asyncFetchAcquireRelease + (do threadDelay failAcquireDelay; failAcquire) + (\_ -> do threadDelay failReleaseDelay; failRelease) + (\_ -> do threadDelay failDispatchDelay; failDispatch) + (\_ -> do threadDelay failWaitDelay; failWait) + submit state + where + submit :: () -> FailAfter a -> IO (IO (Either SomeException a)) + submit _ (FailAfter t) = do + threadDelay t + return (return (Left (toException (FetchError "failed request")))) + +-- Every data source should define a function 'initGlobalState' that +-- initialises the state for that data source. The arguments to this +-- function might vary depending on the data source - we might need to +-- pass in resources from the environment, or parameters to set up the +-- data source. +initGlobalState :: IO (State FailAfter) +initGlobalState = do + return FailAfterState + { failAcquireDelay = 0 + , failAcquire = return () + , failReleaseDelay = 0 + , failRelease = return () + , failDispatchDelay = 0 + , failDispatch = return () + , failWaitDelay = 0 + , failWait = return () + } diff --git a/tests/BatchTests.hs b/tests/BatchTests.hs --- a/tests/BatchTests.hs +++ b/tests/BatchTests.hs @@ -176,6 +176,103 @@ Left (NotFound "xxx") -> True _ -> False +pOrTests = do + env <- makeTestEnv + + -- Test semantics + r <- runHaxl env $ do + a <- return False `pOr` return False + b <- return False `pOr` return True + c <- return True `pOr` return False + d <- return True `pOr` return True + return (not a && b && c && d) + assertBool "pOr0" r + + -- pOr is left-biased with respsect to exceptions: + r <- runHaxl env $ try $ return True `pOr` throw (NotFound "foo") + assertBool "pOr1" $ + case (r :: Either NotFound Bool) of + Right True -> True + _ -> False + r <- runHaxl env $ try $ throw (NotFound "foo") `pOr` return True + assertBool "pOr2" $ + case (r :: Either NotFound Bool) of + Left (NotFound "foo") -> True + _ -> False + + -- pOr is non-deterministic (see also Note [tricky pOr/pAnd]) + let nondet = (do _ <- friendsOf 1; throw (NotFound "foo")) `pOr` return True + r <- runHaxl env $ try nondet + assertBool "pOr3" $ + case (r :: Either NotFound Bool) of + Right True -> True + _ -> False + -- next we populate the cache + _ <- runHaxl env $ friendsOf 1 + -- and now exactly the same pOr again will throw this time: + r <- runHaxl env $ try nondet + assertBool "pOr4" $ + case (r :: Either NotFound Bool) of + Left (NotFound "foo") -> True + _ -> False + + -- One more test: Blocked/False => Blocked + r <- runHaxl env $ try $ + (do _ <- friendsOf 2; throw (NotFound "foo")) `pOr` return False + assertBool "pOr5" $ + case (r :: Either NotFound Bool) of + Left (NotFound _) -> True + _ -> False + +pAndTests = do + env <- makeTestEnv + + -- Test semantics + r <- runHaxl env $ do + a <- return False `pAnd` return False + b <- return False `pAnd` return True + c <- return True `pAnd` return False + d <- return True `pAnd` return True + return (not a && not b && not c && d) + assertBool "pAnd0" r + + -- pAnd is left-biased with respsect to exceptions: + r <- runHaxl env $ try $ return False `pAnd` throw (NotFound "foo") + assertBool "pAnd1" $ + case (r :: Either NotFound Bool) of + Right False -> True + _ -> False + r <- runHaxl env $ try $ throw (NotFound "foo") `pAnd` return False + assertBool "pAnd2" $ + case (r :: Either NotFound Bool) of + Left (NotFound "foo") -> True + _ -> False + + -- pAnd is non-deterministic (see also Note [tricky pOr/pAnd]) + let nondet = + (do _ <- friendsOf 1; throw (NotFound "foo")) `pAnd` return False + r <- runHaxl env $ try nondet + assertBool "pAnd3" $ + case (r :: Either NotFound Bool) of + Right False -> True + _ -> False + -- next we populate the cache + _ <- runHaxl env $ friendsOf 1 + -- and now exactly the same pAnd again will throw this time: + r <- runHaxl env $ try nondet + assertBool "pAnd4" $ + case (r :: Either NotFound Bool) of + Left (NotFound "foo") -> True + _ -> False + + -- One more test: Blocked/True => Blocked + r <- runHaxl env $ try $ + (do _ <- friendsOf 2; throw (NotFound "foo")) `pAnd` return True + assertBool "pAnd5" $ + case (r :: Either NotFound Bool) of + Left (NotFound _) -> True + _ -> False + tests = TestList [ TestLabel "batching1" $ TestCase batching1 , TestLabel "batching2" $ TestCase batching2 @@ -194,4 +291,6 @@ , TestLabel "exceptionTest1" $ TestCase exceptionTest1 , TestLabel "exceptionTest2" $ TestCase exceptionTest2 , TestLabel "deterministicExceptions" $ TestCase deterministicExceptions + , TestLabel "pOrTest" $ TestCase pOrTests + , TestLabel "pAndTest" $ TestCase pAndTests ] diff --git a/tests/ProfileTests.hs b/tests/ProfileTests.hs --- a/tests/ProfileTests.hs +++ b/tests/ProfileTests.hs @@ -24,14 +24,15 @@ collectsdata :: Assertion collectsdata = do - env <- mkProfilingEnv - _x <- runHaxl env $ + e <- mkProfilingEnv + _x <- runHaxl e $ withLabel "bar" $ - withLabel "foo" $ - if length (intersect ["a"::Text, "b"] ["c"]) > 1 + withLabel "foo" $ do + u <- env userEnv + if length (intersect (HashMap.keys u) ["c"]) > 1 then return 5 else return (4::Int) - profData <- profile <$> readIORef (profRef env) + profData <- profile <$> readIORef (profRef e) assertEqual "has data" 3 $ HashMap.size profData assertBool "foo allocates" $ case profileAllocs <$> HashMap.lookup "foo" profData of diff --git a/tests/TestBadDataSource.hs b/tests/TestBadDataSource.hs new file mode 100644 --- /dev/null +++ b/tests/TestBadDataSource.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} +module TestBadDataSource (tests) where + +import Haxl.Prelude as Haxl +import Prelude() + +import Haxl.Core + +import Data.IORef +import Test.HUnit +import Control.Exception + +import ExampleDataSource +import BadDataSource + +testEnv fn = do + exstate <- ExampleDataSource.initGlobalState + badstate <- BadDataSource.initGlobalState + let st = stateSet exstate $ stateSet (fn badstate) stateEmpty + initEnv st () + +wombats :: GenHaxl () Int +wombats = length <$> listWombats 3 + +badDataSourceTest :: Test +badDataSourceTest = TestCase $ do + -- test that a failed acquire doesn't fail the other requests + ref <- newIORef False + env <- testEnv $ \st -> + st { failAcquire = throwIO (DataSourceError "acquire") + , failRelease = writeIORef ref True } + + x <- runHaxl env $ + (dataFetch (FailAfter 0) + wombats) + `Haxl.catch` \DataSourceError{} -> wombats + + assertEqual "badDataSourceTest1" 3 x + + -- We should *not* have called release + assertEqual "badDataSourceTest2" False =<< readIORef ref + + -- test that a failed dispatch doesn't fail the other requests + ref <- newIORef False + env <- testEnv $ \st -> + st { failDispatch = throwIO (DataSourceError "dispatch") + , failRelease = writeIORef ref True } + + x <- runHaxl env $ + (dataFetch (FailAfter 0) + wombats) + `Haxl.catch` \DataSourceError{} -> wombats + + assertEqual "badDataSourceTest3" x 3 + + -- We *should* have called release + assertEqual "badDataSourceTest4" True =<< readIORef ref + + -- test that a failed wait is a DataSourceError + env <- testEnv $ \st -> + st { failWait = throwIO (DataSourceError "wait") } + + x <- runHaxl env $ + (dataFetch (FailAfter 0) + wombats) + `Haxl.catch` \DataSourceError{} -> wombats + + assertEqual "badDataSourceTest5" x 3 + + -- We *should* have called release + assertEqual "badDataSourceTest6" True =<< readIORef ref + + -- test that a failed release is still a DataSourceError, even + -- though the request will have completed successfully + env <- testEnv $ \st -> + st { failRelease = throwIO (DataSourceError "release") } + + x <- runHaxl env $ + (dataFetch (FailAfter 0) + wombats) + `Haxl.catch` \DataSourceError{} -> wombats + + assertEqual "badDataSourceTest7" x 3 + + + + +tests = TestList + [ TestLabel "badDataSourceTest" badDataSourceTest + ] diff --git a/tests/TestExampleDataSource.hs b/tests/TestExampleDataSource.hs --- a/tests/TestExampleDataSource.hs +++ b/tests/TestExampleDataSource.hs @@ -10,7 +10,9 @@ import qualified Data.HashMap.Strict as HashMap import Test.HUnit import Data.IORef +import Data.Maybe import Control.Exception +import System.Environment import System.FilePath import ExampleDataSource @@ -174,7 +176,12 @@ env <- testEnv runHaxl env loadCache str <- runHaxl env dumpCacheAsHaskell - loadcache <- readFile $ dropFileName __FILE__ "LoadCache.txt" + lcPath <- loadCachePath + loadcache <- readFile lcPath -- The order of 'cacheRequest ...' calls is nondeterministic and -- differs among GHC versions, so we sort the lines for comparison. assertEqual "dumpCacheAsHaskell" (sort $ lines loadcache) (sort $ lines str) + where + loadCachePath = do + lcEnv <- lookupEnv "LOADCACHE" + return $ fromMaybe (dropFileName __FILE__ "LoadCache.txt") lcEnv