immortal 0.1 → 0.2

raw patch · 5 files changed

+129/−16 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• README.md +20/−0
• immortal.cabal +4/−2
• src/Control/Immortal.hs +35/−7
• tests/test.hs +62/−7

@@ -0,0 +1,8 @@+CHANGES+=======++Version 0.2+-----------++* Pass a `Thread` handle to the thread itself+* Add `mortalize`, `immortalize`

@@ -0,0 +1,20 @@+immortal+========++A small library to create threads that never die. This is useful e.g. for+writing servers.++``` haskell+import qualified System.Immortal as Immortal+import Control.Concurrent (threadDelay)+import Control.Monad (forever)++main = do+  -- start an immortal thread+  _ <- Immortal.create $ do+    -- do stuff++  -- in the main thread, sleep until interrupted+  -- (e.g. with Ctrl-C)+  forever $ threadDelay maxBound+```

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                immortal-version:             0.1+version:             0.2 synopsis:            Spawn threads that never die (unless told to do so) -- description:          homepage:            https://github.com/feuerbach/immortal@@ -13,7 +13,9 @@ -- copyright:            category:            Concurrency build-type:          Simple--- extra-source-files:  +extra-source-files:+  README.md+  CHANGELOG.md cabal-version:       >=1.10  library

@@ -6,6 +6,8 @@   ( Thread   , create   , createWithLabel+  , mortalize+  , immortalize   , stop   , threadId   , onFinish@@ -33,7 +35,10 @@ -- It is completely safe, however, to instantiate @m@ with -- something like @ReaderT conf IO@ to pass configuration to the new -- thread.-create :: MonadBaseControl IO m => m () -> m Thread+create+  :: MonadBaseControl IO m+  => (Thread -> m ())+  -> m Thread create a = uninterruptibleMask $ \restore -> do   -- Why use uninterruptibleMask instead of just mask? We're not using any   -- blocking operations so far, so there should be no difference. Still,@@ -43,7 +48,12 @@   stopRef <- liftBase $ newIORef False   let     go = do-      handle (\(_ :: SomeException) -> return ()) (restore a)+      -- construct a thread object from within the thread itself+      pid <- myThreadId+      let thread = Thread pid stopRef++      handle (\(_ :: SomeException) -> return ()) (restore $ a thread)+       stopNow <- liftBase $ readIORef stopRef       unless stopNow go   pid <- fork go@@ -51,19 +61,37 @@  -- | Like 'create', but also apply the given label to the thread -- (using 'labelThread').-createWithLabel :: MonadBaseControl IO m => String -> m () -> m Thread+createWithLabel :: MonadBaseControl IO m => String -> (Thread -> m ()) -> m Thread createWithLabel label a = do   thread <- create a   liftBase $ labelThread (threadId thread) label   return thread +-- | Make a thread mortal. Next time a mortal thread attempts to finish,+-- nothing will prevent it from doing so.+--+-- Calling this on an already mortalized thread has no effect.+mortalize :: Thread -> IO ()+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+ -- | Stop (kill) an immortal thread. ----- This is the only way to really stop an immortal thread.+-- This is equivalent to making it mortal, and then killing it with+-- an exception.+--+-- Note that if the thread has installed its own exception handlers, it may+-- not be killed immediately. stop :: Thread -> IO ()-stop (Thread pid stopRef) = do-  writeIORef stopRef True-  killThread pid+stop t = do+  mortalize t+  killThread (threadId t)  -- | Get the 'ThreadId' of the immortal thread. --

@@ -14,14 +14,14 @@ -- See http://ro-che.info/articles/2014-07-30-bracket.html withImmortal :: IO () -> IO c -> IO c withImmortal comp inner = do-  thread <- Immortal.create comp+  thread <- Immortal.create $ const comp   inner `finally` Immortal.stop thread  main :: IO () main = defaultMain $ testGroup "Tests"   [ testCase "is not killed by an exception" $ do       tv <- atomically $ newTVar True-      immortal <- Immortal.create $ keepTrue tv+      immortal <- Immortal.create $ const $ keepTrue tv        killThread (Immortal.threadId immortal)       atomically $ writeTVar tv False@@ -40,7 +40,7 @@    , testCase "can be stopped" $ do       tv <- atomically $ newTVar True-      immortal <- Immortal.create $ keepTrue tv+      immortal <- Immortal.create $ const $ keepTrue tv        Immortal.stop immortal       atomically $ writeTVar tv False@@ -50,10 +50,11 @@    , testCase "state is preserved when there are no exceptions" $ do       tv <- atomically $ newTVar 0-      bracket (flip evalStateT 0 $ Immortal.create $ countToFive tv) Immortal.stop $ \_ -> do+      pid <- flip evalStateT 0 $ Immortal.create $ const $ countToFive tv+      (do         delay         v <- atomically $ readTVar tv-        v @?= 5+        v @?= 5) `finally` Immortal.stop pid    , testCase "state is reset when there are exceptions" $ do       tv <- atomically $ newTVar 0@@ -62,10 +63,12 @@           countToFive tv           liftIO delay           error "bah!"-      bracket (flip evalStateT 0 $ Immortal.create computation) Immortal.stop $ \_ -> do+      pid <- flip evalStateT 0 $ Immortal.create $ const computation+      (do         threadDelay (5*10^5)         v <- atomically $ readTVar tv-        v @?= 0+        v @?= 0)+        `finally` Immortal.stop pid    , testCase "onFinish detects normal exit" $ do       tv <- atomically $ newTVar Nothing@@ -94,6 +97,58 @@         case v of           Just (Left (fromException -> Just (ErrorCall "bah!"))) -> return ()           _ -> assertFailure $ "unexpected result: " ++ show v++  , testCase "mortalize allows thread to finish" $ do+      tv <- atomically $ newTVar True+      t <- Immortal.create $ const $ keepTrue tv+      Immortal.mortalize t+      atomically $ writeTVar tv False+      delay+      v1 <- atomically $ readTVar tv+      -- thread was waiting for this; v1 should be True+      v1 @?= True+      -- since the thread was mortalized, it shouldn't be restarted+      -- so try the same actions again+      atomically $ writeTVar tv False+      delay+      v2 <- atomically $ readTVar tv+      -- and we now should get False+      v2 @?= False++  , testCase "immortalize cancels mortalize" $ do+      -- this is the copy of the previous test, only after mortalize we+      -- immediately call immortalize+      tv <- atomically $ newTVar True+      t <- Immortal.create $ const $ keepTrue tv+      Immortal.mortalize t+      Immortal.immortalize t+      atomically $ writeTVar tv False+      delay+      v1 <- atomically $ readTVar tv+      v1 @?= True+      atomically $ writeTVar tv False+      delay+      v2 <- atomically $ readTVar tv+      v2 @?= True+      Immortal.stop t++  , testCase "cancelling from within the thread works" $ do+      -- tv1 checks that the thread stopped running+      -- tv2 checks that the exception was thrown+      tv1 <- atomically $ newTVar False+      tv2 <- atomically $ newTVar False+      t <- Immortal.create $ \thread -> do+        keepTrue tv1+        Immortal.stop thread+        atomically $ writeTVar tv1 True++      delay+      atomically $ writeTVar tv1 False+      delay+      v1 <- atomically $ readTVar tv1+      v2 <- atomically $ readTVar tv2+      v1 @?= False+      v2 @?= False   ]  keepTrue :: TVar Bool -> IO ()