summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRomanCheplyaka <>2014-08-09 12:37:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-08-09 12:37:00 (GMT)
commitf547651de339a714ddf951aa1fb086a8f06757cc (patch)
tree21d7abb1911452afa1b3f9335cb87d4fabffa3d7
version 0.10.1
-rw-r--r--LICENSE20
-rw-r--r--Setup.hs2
-rw-r--r--immortal.cabal48
-rw-r--r--src/Control/Immortal.hs87
-rw-r--r--tests/test.hs117
5 files changed, 274 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..8524baa
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,20 @@
+Copyright (c) 2014 Roman Cheplyaka
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/immortal.cabal b/immortal.cabal
new file mode 100644
index 0000000..395845f
--- /dev/null
+++ b/immortal.cabal
@@ -0,0 +1,48 @@
+-- Initial immortal.cabal generated by cabal init. For further
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name: immortal
+version: 0.1
+synopsis: Spawn threads that never die (unless told to do so)
+-- description:
+homepage: https://github.com/feuerbach/immortal
+license: MIT
+license-file: LICENSE
+author: Roman Cheplyaka
+maintainer: roma@ro-che.info
+-- copyright:
+category: Concurrency
+build-type: Simple
+-- extra-source-files:
+cabal-version: >=1.10
+
+library
+ exposed-modules: Control.Immortal
+ -- other-modules:
+ build-depends:
+ base >=4.5 && <5,
+ lifted-base >=0.2,
+ transformers-base >=0.4,
+ monad-control >=0.3
+ hs-source-dirs: src
+ default-language: Haskell2010
+ ghc-options: -Wall
+
+test-suite test
+ default-language:
+ Haskell2010
+ type:
+ exitcode-stdio-1.0
+ hs-source-dirs:
+ tests
+ main-is:
+ test.hs
+ build-depends:
+ base >= 4 && < 5
+ , tasty >= 0.8
+ , tasty-hunit
+ , immortal
+ , transformers
+ , stm
+ , lifted-base
+ ghc-options: -Wall
diff --git a/src/Control/Immortal.hs b/src/Control/Immortal.hs
new file mode 100644
index 0000000..369eeff
--- /dev/null
+++ b/src/Control/Immortal.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FlexibleContexts #-}
+-- | This module is designed to be imported qualified, e.g.
+--
+-- >import qualified Control.Immortal as Immortal
+module Control.Immortal
+ ( Thread
+ , create
+ , createWithLabel
+ , stop
+ , threadId
+ , onFinish
+ ) 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)
+
+-- | Immortal thread identifier (including its underlying 'ThreadId')
+data Thread = Thread ThreadId (IORef Bool)
+
+-- | Spawn a new immortal thread running the given computation.
+--
+-- If the computation ever finishes (either normally or due to an exception),
+-- it will be restarted (in the same thread).
+--
+-- The monadic «state» (captured by the 'MonadBaseControl' instance) will
+-- be preserved if the computation terminates normally, and reset when the
+-- exception is thrown, so be cautious when @m@ is stateful.
+-- 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 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,
+ -- 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
+ let
+ go = do
+ handle (\(_ :: SomeException) -> return ()) (restore a)
+ stopNow <- liftBase $ readIORef stopRef
+ unless stopNow go
+ pid <- fork go
+ return $ Thread pid stopRef
+
+-- | Like 'create', but also apply the given label to the thread
+-- (using 'labelThread').
+createWithLabel :: MonadBaseControl IO m => String -> m () -> m Thread
+createWithLabel label a = do
+ thread <- create a
+ liftBase $ labelThread (threadId thread) label
+ return thread
+
+-- | Stop (kill) an immortal thread.
+--
+-- This is the only way to really stop an immortal thread.
+stop :: Thread -> IO ()
+stop (Thread pid stopRef) = do
+ writeIORef stopRef True
+ killThread pid
+
+-- | 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
+
+-- | 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
+--
+-- This is nothing more than a simple wrapper around 'try'.
+onFinish
+ :: MonadBaseControl IO m
+ => (Either SomeException () -> m ())
+ -> m () -> m ()
+onFinish cb a = try a >>= cb
diff --git a/tests/test.hs b/tests/test.hs
new file mode 100644
index 0000000..b633c30
--- /dev/null
+++ b/tests/test.hs
@@ -0,0 +1,117 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+import Test.Tasty
+import Test.Tasty.HUnit
+import qualified Control.Immortal as Immortal
+import Control.Monad
+import Control.Exception
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Monad.Trans.State
+import Control.Monad.IO.Class
+
+-- Almost bracket, but we don't want to start a thread inside mask
+-- 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
+ 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
+
+ killThread (Immortal.threadId immortal)
+ atomically $ writeTVar tv False
+ delay
+ v <- atomically $ readTVar tv
+ assertBool "Thread died" v
+
+ , testCase "never finishes" $ do
+ tv <- atomically $ newTVar False
+ withImmortal (keepTrue tv) $
+ replicateM_ 10 $ do
+ atomically $ writeTVar tv False
+ delay
+ v <- atomically $ readTVar tv
+ assertBool "Thread died" v
+
+ , testCase "can be stopped" $ do
+ tv <- atomically $ newTVar True
+ immortal <- Immortal.create $ keepTrue tv
+
+ Immortal.stop immortal
+ atomically $ writeTVar tv False
+ delay
+ v <- atomically $ readTVar tv
+ assertBool "Thread did not stop" (not v)
+
+ , 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
+ delay
+ v <- atomically $ readTVar tv
+ v @?= 5
+
+ , testCase "state is reset when there are exceptions" $ do
+ tv <- atomically $ newTVar 0
+ let
+ computation = do
+ countToFive tv
+ liftIO delay
+ error "bah!"
+ bracket (flip evalStateT 0 $ Immortal.create computation) Immortal.stop $ \_ -> do
+ threadDelay (5*10^5)
+ v <- atomically $ readTVar tv
+ v @?= 0
+
+ , testCase "onFinish detects normal exit" $ do
+ tv <- atomically $ newTVar Nothing
+ let
+ comp =
+ Immortal.onFinish
+ (\r -> atomically $ writeTVar tv (Just r))
+ (liftIO delay)
+ withImmortal comp $ do
+ threadDelay (2*10^5)
+ v <- atomically $ readTVar tv
+ case v of
+ Just (Right ()) -> return ()
+ _ -> assertFailure $ "unexpected result: " ++ show v
+
+ , testCase "onFinish detects normal exit" $ do
+ tv <- atomically $ newTVar Nothing
+ let
+ comp =
+ Immortal.onFinish
+ (\r -> atomically $ writeTVar tv (Just r))
+ (do liftIO delay; error "bah!")
+ withImmortal comp $ do
+ threadDelay (2*10^5)
+ v <- atomically $ readTVar tv
+ case v of
+ Just (Left (fromException -> Just (ErrorCall "bah!"))) -> return ()
+ _ -> assertFailure $ "unexpected result: " ++ show v
+ ]
+
+keepTrue :: TVar Bool -> IO ()
+keepTrue tv = atomically $ do
+ v <- readTVar tv
+ check $ not v
+ writeTVar tv True
+
+sleep :: IO ()
+sleep = threadDelay (60 * 10^6) -- 1 min
+
+delay :: IO ()
+delay = threadDelay (10^5) -- 0.1 s
+
+countToFive :: TVar Int -> StateT Int IO ()
+countToFive tv = do
+ n <- get
+ liftIO $ atomically $ writeTVar tv n
+ if n == 5
+ then liftIO sleep
+ else put $! n+1