resourcet-1.3.0: test/main.hs

{-# LANGUAGE DeriveDataTypeable  #-}
{-# LANGUAGE ScopedTypeVariables #-}

import           Control.Concurrent
import           Control.Exception            (Exception, MaskingState (MaskedInterruptible),
                                               getMaskingState, throwIO, try, fromException)
import           Control.Exception            (SomeException, handle)
import           Control.Monad                (unless, void)
import qualified Control.Monad.Catch
import           Control.Monad.IO.Class       (liftIO)
import           Control.Monad.Trans.Resource
import           Data.IORef
import           Data.Typeable                (Typeable)
import           Test.Hspec
import           Data.Acquire

main :: IO ()
main = hspec $ do
    describe "general" $ do
        it "survives releasing bottom" $ do
            x <- newIORef (0 :: Int)
            handle (\(_ :: SomeException) -> return ()) $ runResourceT $ do
                _ <- register $ writeIORef x 1
                release undefined
            x' <- readIORef x
            x' `shouldBe` 1
    describe "early release" $ do
        it "works from a different context" $ do
            x <- newIORef (0 :: Int)
            runResourceT $ do
                key <- register $ writeIORef x 1
                runResourceT $ release key
                y <- liftIO $ readIORef x
                liftIO $ y `shouldBe` 1
    describe "resourceForkIO" $ do
        it "waits for all threads" $ do
            x <- newEmptyMVar
            y <- newIORef (0 :: Int)
            z <- newEmptyMVar
            w <- newEmptyMVar

            _ <- runResourceT $ do
                _ <- register $ do
                    writeIORef y 1
                    putMVar w ()
                resourceForkIO $ do
                    () <- liftIO $ takeMVar x
                    y' <- liftIO $ readIORef y
                    _ <- register $ putMVar z y'
                    return ()

            y1 <- readIORef y
            y1 `shouldBe` 0

            putMVar x ()

            z' <- takeMVar z
            z' `shouldBe` 0

            takeMVar w
            y2 <- readIORef y
            Just y2 `shouldBe` Just 1
    describe "unprotecting" $ do
        it "unprotect keeps resource from being cleared" $ do
            x <- newIORef (0 :: Int)
            _ <- runResourceT $ do
              key <- register $ writeIORef x 1
              unprotect key
            y <- readIORef x
            y `shouldBe` 0
    it "cleanup actions are masked #144" $ do
        let checkMasked name = do
                ms <- getMaskingState
                unless (ms == MaskedInterruptible) $
                    error $ show (name, ms)
        _ <- runResourceT $ do
            register (checkMasked "release") >>= release
            register (checkMasked "normal")
        Left Dummy <- try $ runResourceT $ do
            _ <- register (checkMasked "exception")
            liftIO $ throwIO Dummy
        return ()
    describe "mkAcquireType" $ do
        describe "ResourceT" $ do
            it "early" $ do
                ref <- newIORef Nothing
                let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just
                runResourceT $ do
                    (releaseKey, ()) <- allocateAcquire acq
                    release releaseKey
                readIORef ref >>= (`shouldSatisfy` just releaseEarly)
            it "normal" $ do
                ref <- newIORef Nothing
                let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just
                runResourceT $ do
                    (_releaseKey, ()) <- allocateAcquire acq
                    return ()
                readIORef ref >>= (`shouldSatisfy` just releaseNormal)
            it "exception" $ do
                ref <- newIORef Nothing
                let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just
                Left Dummy <- try $ runResourceT $ do
                    (_releaseKey, ()) <- allocateAcquire acq
                    liftIO $ throwIO Dummy
                readIORef ref >>= (`shouldSatisfy` just (releaseException dummy))
        describe "with" $ do
            it "normal" $ do
                ref <- newIORef Nothing
                let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just
                with acq $ const $ return ()
                readIORef ref >>= (`shouldSatisfy` just releaseNormal)
            it "exception" $ do
                ref <- newIORef Nothing
                let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just
                Left Dummy <- try $ with acq $ const $ throwIO Dummy
                readIORef ref >>= (`shouldSatisfy` just (releaseException dummy))
    describe "runResourceTChecked" $ do
        it "catches exceptions" $ do
            eres <- try $ runResourceTChecked $ void $ register $ throwIO Dummy
            case eres of
              Right () -> error "Expected an exception"
              Left (ResourceCleanupException Nothing ex []) ->
                case fromException ex of
                  Just Dummy -> return ()
                  Nothing -> error "It wasn't Dummy"
              Left (ResourceCleanupException (Just _) _ []) -> error "Got a ResourceT exception"
              Left (ResourceCleanupException _ _ (_:_)) -> error "Got more than one"
        it "no exception is fine" $ (runResourceTChecked $ void $ register $ return () :: IO ())
        it "catches multiple exceptions" $ do
            eres <- try $ runResourceTChecked $ do
              void $ register $ throwIO Dummy
              void $ register $ throwIO Dummy2
            case eres of
              Right () -> error "Expected an exception"
              Left (ResourceCleanupException Nothing ex1 [ex2]) ->
                case (fromException ex1, fromException ex2) of
                  (Just Dummy, Just Dummy2) -> return ()
                  _ -> error $ "It wasn't Dummy, Dummy2: " ++ show (ex1, ex2)
              Left (ResourceCleanupException (Just _) _ [_]) -> error "Got a ResourceT exception"
              Left (ResourceCleanupException _ _ []) -> error "Only got 1"
              Left (ResourceCleanupException _ _ (_:_:_)) -> error "Got more than 2"
    describe "MonadMask" $
        it "works" (runResourceT $ Control.Monad.Catch.bracket (return ()) (const (return ())) (const (return ())) :: IO ())

data Dummy = Dummy
    deriving (Show, Typeable)
instance Exception Dummy

data Dummy2 = Dummy2
    deriving (Show, Typeable)
instance Exception Dummy2

-- Helpers needed due to lack of 'Eq' on 'ReleaseType'

releaseEarly :: ReleaseType -> Bool
releaseEarly ReleaseEarly = True
releaseEarly _ = False

releaseNormal :: ReleaseType -> Bool
releaseNormal ReleaseNormal = True
releaseNormal _ = False

releaseException :: (Exception e) => Selector e -> ReleaseType -> Bool
releaseException sel (ReleaseExceptionWith se) = case fromException se of
                         Just e -> sel e
                         Nothing -> False
releaseException _ _ = False

just :: (a -> Bool) -> Maybe a -> Bool
just sel (Just x) = sel x
just _ Nothing = False

dummy :: Selector Dummy
dummy Dummy = True