Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Fix exception propagation with upstream yield.

Downstream exceptions need to be caught by the handler of an upstream
yield while downstream is executing.

Discarding the upstream exception handler, as the previous composition
did, is wrong for two reasons:

1. Exception handlers are discarded after composing with a downstream
identity.
2. 'Ensure' actions are not skipped (as they should be) if any action
between a 'yield' and an 'ensure' fails.

This fixes an issue found by Gabriel Gonzales:
http://www.reddit.com/r/haskell/comments/qq5p6/pipescore_001_released/c3zpp82
  • Loading branch information...
commit 68089b9ed11835c1a3934a35db0396cc9127c7e5 1 parent 67efd71
Paolo Capriotti authored
Showing with 48 additions and 21 deletions.
  1. +26 −21 Control/Pipe/Common.hs
  2. +22 −0 Tests.hs
47 Control/Pipe/Common.hs
View
@@ -252,28 +252,33 @@ finalize1 e c = case c of
infixl 9 >+>
-- | Left to right pipe composition.
(>+>) :: Monad m => Pipe a b m r -> Pipe b c m r -> Pipe a c m r
-p1 >+> p2 = case (p1, p2) of
- (Free c1 h1, Free c2 h2) -> case compose c1 c2 of
- Left e -> p1 >+> h2 e
- Right (AdvanceFirst comp) -> catchP comp (return . h1) >>= \p1' -> p1' >+> p2
- Right (AdvanceSecond comp) -> catchP comp (return . h2) >>= \p2' -> p1 >+> p2'
- Right (AdvanceBoth p1' p2') -> p1' >+> p2'
- (Throw e, Free c h) -> terminate2 c h (Just e)
- (Pure r, Free c h) -> terminate2 c h Nothing
- (Free c h, Throw e) -> terminate1 c h (Just e)
- (Free c h, Pure r) -> terminate1 c h Nothing
- (Pure r, Throw e) -> case (E.fromException e :: Maybe BrokenUpstreamPipe) of
- Nothing -> throwP e
- Just _ -> return r
- (_, Throw e) -> throwP e
- (_, Pure r) -> return r
+p1 >+> p2 = go Nothing p1 p2
where
- terminate1 c h e = case finalize1 e c of
- Nothing -> h (fromMaybe (E.toException BrokenDownstreamPipe) e) >+> p2
- Just comp -> catchP comp (return . h) >>= \p1' -> p1' >+> p2
- terminate2 c h e = case finalize2 c of
- Nothing -> p1 >+> h (fromMaybe (E.toException BrokenUpstreamPipe) e)
- Just comp -> catchP comp (return . h) >>= \p2' -> p1 >+> p2'
+ go hu p1 p2 = case (hu, p1, p2) of
+ (_, Free c1 h1, Free c2 h2) -> case compose c1 c2 of
+ Left e -> go hu p1 (h2 e)
+ Right (AdvanceFirst comp) -> catchP comp (return . h1) >>= \p1' -> p1' >+> p2
+ Right (AdvanceSecond comp) -> catchP comp (return . h2) >>= \p2' -> go hu p1 p2'
+ Right (AdvanceBoth p1' p2') -> go (Just h1) p1' p2'
+ (_, Throw e, Free c h) -> terminate2 c h (Just e)
+ (_, Pure r, Free c h) -> terminate2 c h Nothing
+ (_, Free c h, Pure r) -> terminate1 c (fromMaybe throwP hu) Nothing
+ (_, Free c h, Throw e) -> terminate1 c (fromMaybe throwP hu) (Just e)
+ (_, Pure r, Throw e) -> case (E.fromException e :: Maybe BrokenUpstreamPipe) of
+ Nothing -> fromMaybe throwP hu e >+> throwP e
+ Just _ -> return r
+ (_, Throw e1, Throw e2) -> case (E.fromException e2 :: Maybe BrokenUpstreamPipe) of
+ Nothing -> throwP e2
+ Just _ -> throwP e1
+ (Just hu, _, Pure r) -> hu (E.toException BrokenDownstreamPipe) >+> p2
+ (Nothing, _, Pure r) -> return r
+ where
+ terminate1 c h e = case finalize1 e c of
+ Nothing -> h (fromMaybe (E.toException BrokenDownstreamPipe) e) >+> p2
+ Just comp -> catchP comp (return . h) >>= \p1' -> p1' >+> p2
+ terminate2 c h e = case finalize2 c of
+ Nothing -> go hu p1 (h (fromMaybe (E.toException BrokenUpstreamPipe) e))
+ Just comp -> catchP comp (return . h) >>= \p2' -> go hu p1 p2'
infixr 9 <+<
-- | Right to left pipe composition.
22 Tests.hs
View
@@ -92,6 +92,25 @@ prop_finalizer_assoc xs = runWriter (runPurePipe_ p) == runWriter (runPurePipe_
p2 = void await
p3 = tryAwait >>= lift . tell . return
+prop_yield_failure :: Bool
+prop_yield_failure = runWriter (runPurePipe_ p) == runWriter (runPurePipe_ p')
+ where
+ p = p1 >+> return ()
+ p' = (p1 >+> idP) >+> return ()
+ p1 = yield () >> ensure (tell [1])
+
+prop_yield_failure_assoc :: Bool
+prop_yield_failure_assoc = runWriter (runPurePipe_ p) == runWriter (runPurePipe_ p')
+ where
+ p = p1 >+> (idP >+> return ())
+ p' = (p1 >+> idP) >+> return ()
+ p1 = yield () >> ensure (tell [1])
+
+prop_bup_leak :: Bool
+prop_bup_leak = either (const False) (== ()) . runIdentity . runPurePipe $ p
+ where
+ p = yield () >+> (await >> await >> return ())
+
main = defaultMain $ [
testGroup "properties" $
[ testProperty "fold" prop_fold
@@ -107,5 +126,8 @@ main = defaultMain $ [
, testProperty "groupBy" prop_groupBy
, testProperty "filter" prop_filter
, testProperty "finalizer assoc" prop_finalizer_assoc
+ , testProperty "yield failure" prop_yield_failure
+ , testProperty "yield failure assoc" prop_yield_failure_assoc
+ , testProperty "bup leak" prop_bup_leak
]
]
Please sign in to comment.
Something went wrong with that request. Please try again.