immortal (empty) → 0.1

raw patch · 5 files changed

+274/−0 lines, 5 filesdep +basedep +immortaldep +lifted-basesetup-changed

Dependencies added: base, immortal, lifted-base, monad-control, stm, tasty, tasty-hunit, transformers, transformers-base

Files

LICENSE +20/−0
Setup.hs +2/−0
immortal.cabal +48/−0
src/Control/Immortal.hs +87/−0
tests/test.hs +117/−0

+ LICENSE view

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

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ immortal.cabal view

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

+ src/Control/Immortal.hs view

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

+ tests/test.hs view

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