haxl 0.5.0.0 → 0.5.1.0

raw patch · 14 files changed

+533/−66 lines, 14 filesdep ~HUnitdep ~aesondep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: HUnit, aeson, base, binary, text, time

API changes (from Hackage documentation)

Files

• Haxl/Core.hs +5/−2
• Haxl/Core/DataCache.hs +1/−1
• Haxl/Core/Exception.hs +49/−2
• Haxl/Core/Monad.hs +92/−43
• Haxl/Core/Types.hs +74/−1
• Haxl/Prelude.hs +1/−0
• changelog.md +7/−0
• haxl.cabal +14/−9
• tests/AllTests.hs +4/−2
• tests/BadDataSource.hs +87/−0
• tests/BatchTests.hs +99/−0
• tests/ProfileTests.hs +6/−5
• tests/TestBadDataSource.hs +86/−0
• tests/TestExampleDataSource.hs +8/−1

@@ -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, 

@@ -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 ((<$>))

@@ -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)

@@ -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.+-}

@@ -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.

@@ -52,6 +52,7 @@     (.==), (./=), (.&&), (.||),     (.++),     pair,+    pAnd, pOr,      -- * Text things     Text,

@@ -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)) 

@@ -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 <haxl-team@fb.com> 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

@@ -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   ]

@@ -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 ()+    }

@@ -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   ]

@@ -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

@@ -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+  ]

@@ -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