1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DeriveDataTypeable #-} 3{-# LANGUAGE ScopedTypeVariables #-} 4module Control.Exception.SafeSpec (spec) where 5 6import Control.Concurrent (threadDelay, newEmptyMVar, forkIOWithUnmask, takeMVar, putMVar) 7import Control.Exception (ArithException (..), AsyncException (..), BlockedIndefinitelyOnMVar (..), BlockedIndefinitelyOnSTM (..)) 8import qualified Control.Exception as E 9import Control.Exception.Safe 10import Control.Monad (forever) 11import Data.Typeable (Typeable) 12import Data.Void (Void, absurd) 13import System.IO.Unsafe (unsafePerformIO) 14import System.Timeout (timeout) 15import Test.Hspec 16#if !MIN_VERSION_base(4,9,0) 17import System.IO.Error (isUserError) 18#endif 19 20newtype ExceptionPred = ExceptionPred { getExceptionPred :: Maybe () } deriving (Show, Eq, Typeable) 21 22instance Exception ExceptionPred 23 24-- | Ugly hack needed because the underlying type is not exported 25timeoutException :: SomeException 26timeoutException = 27 case unsafePerformIO $ mask $ \restore -> timeout 1 $ tryAsync $ restore $ forever $ threadDelay maxBound of 28 Nothing -> error "timeoutException returned Nothing" 29 Just (Left e) -> e 30 Just (Right e) -> absurd e 31 32asyncE :: IO a 33asyncE = E.throwIO ThreadKilled 34 35syncE :: IO a 36syncE = E.throwIO Overflow 37 38-- | Maps each exception to whether it is synchronous 39exceptions :: [(SomeException, Bool)] 40exceptions = 41 [ go Overflow True 42 , go ThreadKilled False 43 , go timeoutException False 44 , go BlockedIndefinitelyOnMVar True -- see the README, this is weird 45 , go BlockedIndefinitelyOnSTM True -- see the README, this is weird 46 ] 47 where 48 go e b = (toException e, b) 49 50withAll :: (SomeException -> Bool -> IO ()) -> Spec 51withAll f = mapM_ (\(e, b) -> it (show e) (f e b)) exceptions 52 53spec :: Spec 54spec = do 55 describe "isSyncException" $ withAll 56 $ \e sync -> isSyncException e `shouldBe` sync 57 describe "isAsncException" $ withAll 58 $ \e sync -> isAsyncException e `shouldBe` not sync 59 describe "toSyncException" $ withAll 60 $ \e _ -> isSyncException (toSyncException e) `shouldBe` True 61 describe "toAsyncException" $ withAll 62 $ \e _ -> isAsyncException (toAsyncException e) `shouldBe` True 63 64 let shouldBeSync :: Either SomeException Void -> IO () 65 shouldBeSync (Left e) 66 | isSyncException e = return () 67 | otherwise = error $ "Unexpected async exception: " ++ show e 68 shouldBeSync (Right x) = absurd x 69 70 shouldBeAsync :: Either SomeException Void -> IO () 71 shouldBeAsync (Left e) 72 | isAsyncException e = return () 73 | otherwise = error $ "Unexpected sync exception: " ++ show e 74 shouldBeAsync (Right x) = absurd x 75 76 shouldThrowSync f = E.try f >>= shouldBeSync 77 shouldThrowAsync f = E.try f >>= shouldBeAsync 78 79 describe "throw" $ withAll $ \e _ -> shouldThrowSync (throw e) 80 describe "throwTo" $ withAll $ \e _ -> do 81 var <- newEmptyMVar 82 tid <- E.uninterruptibleMask_ $ forkIOWithUnmask $ \restore -> do 83 res <- E.try $ restore $ forever $ threadDelay maxBound 84 putMVar var res 85 throwTo tid e 86 res <- takeMVar var 87 shouldBeAsync res 88 89 describe "stays async" $ do 90 let withPairs f = do 91 it "sync/sync" $ shouldThrowSync $ f syncE syncE 92 93 -- removing this case from consideration, since cleanup handlers 94 -- cannot receive async exceptions. See 95 -- https://github.com/fpco/safe-exceptions/issues/2 96 -- 97 -- it "sync/async" $ shouldThrowAsync $ f syncE asyncE 98 99 it "async/sync" $ shouldThrowAsync $ f asyncE syncE 100 it "async/async" $ shouldThrowAsync $ f asyncE asyncE 101 describe "onException" $ withPairs $ \e1 e2 -> e1 `onException` e2 102 describe "withException" $ withPairs $ \e1 e2 -> e1 `withException` (\(_ :: SomeException) -> e2) 103 describe "bracket_" $ withPairs $ \e1 e2 -> bracket_ (return ()) e2 e1 104 describe "finally" $ withPairs $ \e1 e2 -> e1 `finally` e2 105 describe "bracketOnError_" $ withPairs $ \e1 e2 -> bracketOnError_ (return ()) e2 e1 106 107 describe "deepseq" $ do 108 describe "catchAnyDeep" $ withAll $ \e _ -> do 109 res <- return (impureThrow e) `catchAnyDeep` \_ -> return () 110 res `shouldBe` () 111 describe "handleAnyDeep" $ withAll $ \e _ -> do 112 res <- handleAnyDeep (const $ return ()) (return (impureThrow e)) 113 res `shouldBe` () 114 describe "tryAnyDeep" $ withAll $ \e _ -> do 115 res <- tryAnyDeep (return (impureThrow e)) 116 -- deal with a missing NFData instance 117 shouldBeSync $ either Left (\() -> Right undefined) res 118 describe "catchesDeep" $ withAll $ \e _ -> do 119 res <- return (impureThrow e) `catchesDeep` [Handler (\(_ :: SomeException) -> return ())] 120 res `shouldBe` () 121 122 describe "catchJust" $ do 123 it "catches a selected exception" $ do 124 res <- catchJust getExceptionPred (throw (ExceptionPred (Just ()))) (return . Just) 125 res `shouldBe` Just () 126 127 it "re-raises a selection that is passed on" $ do 128 let ex = ExceptionPred Nothing 129 res <- try (catchJust getExceptionPred (throw ex) (return . Just)) 130 res `shouldBe` Left ex 131 132 describe "throwString" $ do 133 it "is a StringException" $ 134 throwString "foo" `catch` \(StringException _ _) -> return () :: IO () 135