summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRomanCheplyaka <>2014-08-10 14:03:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-08-10 14:03:00 (GMT)
commitdbda9464da5c74add7009d8bf302658113d02213 (patch)
treed78c742baba649b593b0f49dca6bd1caa4bf3d6b
parentf547651de339a714ddf951aa1fb086a8f06757cc (diff)
version 0.20.2
-rw-r--r--CHANGELOG.md8
-rw-r--r--README.md20
-rw-r--r--immortal.cabal6
-rw-r--r--src/Control/Immortal.hs42
-rw-r--r--tests/test.hs69
5 files changed, 129 insertions, 16 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
index 0000000..f836797
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,8 @@
+CHANGES
+=======
+
+Version 0.2
+-----------
+
+* Pass a `Thread` handle to the thread itself
+* Add `mortalize`, `immortalize`
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..21163ee
--- /dev/null
+++ b/README.md
@@ -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
+```
diff --git a/immortal.cabal b/immortal.cabal
index 395845f..0bb66b0 100644
--- a/immortal.cabal
+++ b/immortal.cabal
@@ -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 @@ maintainer: roma@ro-che.info
-- copyright:
category: Concurrency
build-type: Simple
--- extra-source-files:
+extra-source-files:
+ README.md
+ CHANGELOG.md
cabal-version: >=1.10
library
diff --git a/src/Control/Immortal.hs b/src/Control/Immortal.hs
index 369eeff..5ca2d91 100644
--- a/src/Control/Immortal.hs
+++ b/src/Control/Immortal.hs
@@ -6,6 +6,8 @@ module Control.Immortal
( Thread
, create
, createWithLabel
+ , mortalize
+ , immortalize
, stop
, threadId
, onFinish
@@ -33,7 +35,10 @@ data Thread = Thread ThreadId (IORef Bool)
-- 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 @@ create a = uninterruptibleMask $ \restore -> do
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 @@ create a = uninterruptibleMask $ \restore -> do
-- | 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.
--
diff --git a/tests/test.hs b/tests/test.hs
index b633c30..35e4cb3 100644
--- a/tests/test.hs
+++ b/tests/test.hs
@@ -14,14 +14,14 @@ import Control.Monad.IO.Class
-- 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 @@ main = defaultMain $ testGroup "Tests"
, 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 @@ main = defaultMain $ testGroup "Tests"
, 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 @@ main = defaultMain $ testGroup "Tests"
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 @@ main = defaultMain $ testGroup "Tests"
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 ()