diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,16 @@ CHANGES ======= +Version 0.2.2 +------------- + +Add `onUnexpectedFinish` + +Version 0.2.1 +------------- + +Add `wait` and `wait-stm` functions + Version 0.2 ----------- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,7 +11,7 @@ main = do -- start an immortal thread - _ <- Immortal.create $ do + _thread <- Immortal.create $ \ _thread -> do -- do stuff -- in the main thread, sleep until interrupted diff --git a/immortal.cabal b/immortal.cabal --- a/immortal.cabal +++ b/immortal.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: immortal -version: 0.2 +version: 0.2.2 synopsis: Spawn threads that never die (unless told to do so) -- description: homepage: https://github.com/feuerbach/immortal @@ -25,7 +25,8 @@ base >=4.5 && <5, lifted-base >=0.2, transformers-base >=0.4, - monad-control >=0.3 + monad-control >=0.3, + stm hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Control/Immortal.hs b/src/Control/Immortal.hs --- a/src/Control/Immortal.hs +++ b/src/Control/Immortal.hs @@ -9,20 +9,23 @@ , mortalize , immortalize , stop + , wait + , waitSTM , threadId , onFinish + , onUnexpectedFinish ) where import Control.Exception.Lifted -import Control.Monad import Control.Monad.Base import Control.Monad.Trans.Control import Control.Concurrent.Lifted import Data.IORef import GHC.Conc (labelThread) +import Control.Concurrent.STM -- | Immortal thread identifier (including its underlying 'ThreadId') -data Thread = Thread ThreadId (IORef Bool) +data Thread = Thread ThreadId (IORef Bool) (TVar Bool) -- | Spawn a new immortal thread running the given computation. -- @@ -45,19 +48,23 @@ -- better be safe than sorry. Besides, we're using operations from -- `MonadBaseControl` and related instances, and those could potentially -- (though unlikely) block. - stopRef <- liftBase $ newIORef False + stopRef <- liftBase $ newIORef False + finishedRef <- liftBase $ newTVarIO False let go = do -- construct a thread object from within the thread itself pid <- myThreadId - let thread = Thread pid stopRef + let thread = Thread pid stopRef finishedRef handle (\(_ :: SomeException) -> return ()) (restore $ a thread) stopNow <- liftBase $ readIORef stopRef - unless stopNow go + if stopNow then + liftBase $ atomically $ writeTVar finishedRef True + else + go pid <- fork go - return $ Thread pid stopRef + return $ Thread pid stopRef finishedRef -- | Like 'create', but also apply the given label to the thread -- (using 'labelThread'). @@ -72,14 +79,14 @@ -- -- Calling this on an already mortalized thread has no effect. mortalize :: Thread -> IO () -mortalize (Thread _ stopRef) = writeIORef stopRef True +mortalize (Thread _ stopRef _) = writeIORef stopRef True -- | If a thread was 'mortalize'd, this will make it immortal again. However, -- if it finished while being in the mortal state, it won't be resurrected. -- -- Calling this on an immortal thread has no effect. immortalize :: Thread -> IO () -immortalize (Thread _ stopRef) = writeIORef stopRef False +immortalize (Thread _ stopRef _) = writeIORef stopRef False -- | Stop (kill) an immortal thread. -- @@ -93,19 +100,27 @@ mortalize t killThread (threadId t) +-- | Wait for the thread to stop. Use 'stop' to stop the thread +wait :: Thread -> IO () +wait = atomically . waitSTM + +-- | An STM version of 'wait' +waitSTM :: Thread -> STM () +waitSTM (Thread _ _ finishedRef) = check =<< readTVar finishedRef + -- | Get the 'ThreadId' of the immortal thread. -- -- The 'ThreadId' can be used to throw asynchronous exception to interrupt -- the computation. This won't kill the thread, however — even if the -- exception is not handled, the computation will be simply restarted. threadId :: Thread -> ThreadId -threadId (Thread pid _) = pid +threadId (Thread pid _ _) = pid -- | Run a callback every time the action finishes. This can be used e.g. -- to log exceptions or attempts to exit when such attempts are -- not expected. Example usage: -- --- >Immortal.create $ Immortal.onFinish print myAction +-- >Immortal.create $ \_ -> Immortal.onFinish print myAction -- -- This is nothing more than a simple wrapper around 'try'. onFinish @@ -113,3 +128,20 @@ => (Either SomeException () -> m ()) -> m () -> m () onFinish cb a = try a >>= cb + +-- | Like 'onFinish', but the callback does not run when the thread is +-- mortalized (i.e. when the exit is expected). +-- +-- The 'Thread' argument is used to find out the mortality of the thread. +onUnexpectedFinish + :: MonadBaseControl IO m + => Thread + -> (Either SomeException () -> m ()) + -> m () + -> m () +onUnexpectedFinish (Thread _ stopRef _) cb a = do + r <- try a + expected <- liftBase $ readIORef stopRef + if expected + then return () + else cb r diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -9,6 +9,7 @@ import Control.Concurrent.STM import Control.Monad.Trans.State import Control.Monad.IO.Class +import System.Timeout -- Almost bracket, but we don't want to start a thread inside mask -- See http://ro-che.info/articles/2014-07-30-bracket.html @@ -17,6 +18,11 @@ thread <- Immortal.create $ const comp inner `finally` Immortal.stop thread +withImmortalThread :: (Immortal.Thread -> IO ()) -> (Immortal.Thread -> IO c) -> IO c +withImmortalThread comp inner = do + thread <- Immortal.create comp + inner thread `finally` Immortal.stop thread + main :: IO () main = defaultMain $ testGroup "Tests" [ testCase "is not killed by an exception" $ do @@ -84,7 +90,7 @@ Just (Right ()) -> return () _ -> assertFailure $ "unexpected result: " ++ show v - , testCase "onFinish detects normal exit" $ do + , testCase "onFinish detects abnormal exit" $ do tv <- atomically $ newTVar Nothing let comp = @@ -98,6 +104,34 @@ Just (Left (fromException -> Just (ErrorCall "bah!"))) -> return () _ -> assertFailure $ "unexpected result: " ++ show v + , testCase "onUnexpectedFinish fires when thread is immortal" $ do + tv <- atomically $ newTVar Nothing + let + comp thread = + Immortal.onUnexpectedFinish thread + (\r -> atomically $ writeTVar tv (Just r)) + (liftIO delay) + withImmortalThread comp $ \_ -> do + threadDelay (2*10^5) + v <- atomically $ readTVar tv + case v of + Just (Right ()) -> return () + _ -> assertFailure $ "unexpected result: " ++ show v + + , testCase "onUnexpectedFinish does not fire when thread is mortal" $ do + tv <- atomically $ newTVar Nothing + let + comp thread = + Immortal.onUnexpectedFinish thread + (\r -> atomically $ writeTVar tv (Just r)) + (do Immortal.mortalize thread; liftIO delay) + withImmortalThread comp $ \_ -> do + threadDelay (2*10^5) + v <- atomically $ readTVar tv + case v of + Nothing -> return () + _ -> assertFailure $ "unexpected result: " ++ show v + , testCase "mortalize allows thread to finish" $ do tv <- atomically $ newTVar True t <- Immortal.create $ const $ keepTrue tv @@ -137,7 +171,7 @@ -- tv2 checks that the exception was thrown tv1 <- atomically $ newTVar False tv2 <- atomically $ newTVar False - t <- Immortal.create $ \thread -> do + _ <- Immortal.create $ \thread -> do keepTrue tv1 Immortal.stop thread atomically $ writeTVar tv1 True @@ -149,6 +183,13 @@ v2 <- atomically $ readTVar tv2 v1 @?= False v2 @?= False + + , testCase "wait is called after the thread is stopped" $ do + thread <- Immortal.create $ \_ -> threadDelay maxBound + _ <- forkIO $ threadDelay (10^4) >> Immortal.stop thread + result <- timeout (10^5) $ Immortal.wait thread + + result @?= Just () ] keepTrue :: TVar Bool -> IO ()