immortal 0.2 → 0.2.2

raw patch · 5 files changed

+99/−15 lines, 5 files

Files

CHANGELOG.md +10/−0
README.md +1/−1
immortal.cabal +3/−2
src/Control/Immortal.hs +42/−10
tests/test.hs +43/−2

CHANGELOG.md view

@@ -1,6 +1,16 @@ CHANGES ======= +Version 0.2.2+-------------++Add `onUnexpectedFinish`++Version 0.2.1+-------------++Add `wait` and `wait-stm` functions+ Version 0.2 -----------

README.md view

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

immortal.cabal view

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

src/Control/Immortal.hs view

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

tests/test.hs view

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