Throwing asynchronous exceptions on threads with finalizers

AsyncExc.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}

-- | The tools for forking and managing threads from 'Control.Concurrent' and
-- 'Control.Concurrent.Async' don't guarantee that finalizers or exception
-- handlers on the thread are executed when an exception is raised on the
-- thread. This is not an masking issue, but an issue that 'throwTo' doesn't
-- block until finalizers have run to completion. Synchronous delivery of
-- exceptions only guarnatees that the threads computation got interrupted by
-- the asynchronous exception.
--
module Main
( main
) where

import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.MVar
import Control.Exception
import Control.Monad
import Control.Monad.Unicode

import qualified Data.DList as D
import Data.Monoid.Unicode
import qualified Data.Text as T
import qualified Data.Text.IO as T

import Numeric.Natural

import Prelude.Unicode

import System.Exit
import System.IO
import System.IO.Unsafe

-- | Build with
--
-- > ghc -fforce-recomp -threaded AsyncExc.hs
--
-- In order to run in a loop
--
-- for the tests that expect Ctrl-C use:
--
-- > while ./AsyncExc +RTS -N & t=$!; { sleep 1 ; kill -2 $t ; } & wait $t ; do echo "ok" ; done
--
-- for the other tests use:
--
-- > while ./AsyncExc +RTS -N ; do echo $? ; done
--
main ∷ IO ()
main = test5

-- -------------------------------------------------------------------------- --
-- Simple ordering preserving logging

logs ∷ MVar (D.DList T.Text)
logs = unsafePerformIO $ do
    hSetBuffering stdout LineBuffering
    newMVar mempty

printLogs ∷ IO ()
printLogs = readMVar logs ≫= mapM_ T.putStrLn ∘ D.toList

checkLogs
    ∷ Natural
        -- ^ expected number of log messages
    → IO ()
        -- ^ inner test action
    → IO ()
checkLogs n = flip finally $ do
    printLogs
    D.toList <$> readMVar logs ≫= \l → do
        when (length l < fromIntegral n) $ exitFailure
        when (last l ≠ "exit main") $ exitFailure
        exitSuccess

logg ∷ T.Text → IO ()
logg !x = modifyMVar_ logs $ \l → return $! l ⊕ [x]

-- -------------------------------------------------------------------------- --
-- Test functions that expect to be terminate with Ctrl-C (SIGINT)

-- Failed attempts: the finalizers in the brackets are not
-- guaranteed to run to termination.

main1 ∷ IO ()
main1 = checkLogs 6 $ do
    bracket_ (enter "main") (exit "main") $ mask $ \restore → do
        race_ (threadWithMask "a" restore) (threadWithMask "b" restore)

main2 ∷ IO ()
main2 = checkLogs 6 $ do
    bracket_ (enter "main") (exit "main") $ mask $ \restore → do
        altRace_ (threadWithMask "a" restore) (threadWithMask "b" restore)

main3 ∷ IO ()
main3 = checkLogs 4 $ do
    bracket_ (enter "main") (exit "main") $ mask $ \restore → do
        withAsync (threadWithMask "a" restore) wait

-- Correct solutions
--

-- | The 'mask' is not really needed here since the finalizer is
-- part of the 'bracket_'and is not expected to run if the thread is killed
-- before the 'bracket_' is entered.
--
main4 ∷ IO ()
main4 = checkLogs 4 $ do
    bracket_ (enter "main") (exit "main") $ mask $ \restore → do
        withSafeAsync (threadWithMask "a" restore) wait

-- | a version without 'mask'. It is not guaranteed that the inner
-- computation of the thread is entred.
--
main5 ∷ IO ()
main5 = checkLogs 4 $ do
    bracket_ (enter "main") (exit "main") $ do
        withSafeAsync (thread "a") wait

-- | The 'mask' is not really needed here since the finalizer is
-- part of the 'bracket_'and is not expected to run if the thread is killed
-- before the 'bracket_' is entered.
--
main6 ∷ IO ()
main6 = checkLogs 6 $ do
    bracket_ (enter "main") (exit "main") $ mask $ \restore → do
        safeRace_ (threadWithMask "a" restore) (threadWithMask "b" restore)

-- | a version without 'mask'. It is not guaranteed that the inner
-- computation of the thread is entred.
--
main7 ∷ IO ()
main7 = checkLogs 6 $ do
    bracket_ (enter "main") (exit "main") $ do
        safeRace_ (thread "a") (thread "b")

-- -------------------------------------------------------------------------- --
-- Test functions

test1 ∷ IO ()
test1 = checkLogs 4 $ do
    bracket_ (enter "main") (exit "main") $ do
        a ← mask $ \restore → forkIO $ threadWithMask "a" restore
        threadDelay 100
        killThread a

test2 ∷ IO ()
test2 = checkLogs 4 $ do
    bracket_ (enter "main") (exit "main") $ do
        a ← mask $ \restore → async $ threadWithMask "a" restore
        threadDelay 100
        cancel a

-- | this solution guarantees that the finalizer is executed
-- and that the inner function of the thread is entred.
test3 ∷ IO ()
test3 = checkLogs 4 $ do
    bracket_ (enter "main") (exit "main") $ do
        a ← mask $ \restore → async $ threadWithMask "a" restore
        threadDelay 100
        cancel a
        void $ waitCatch a

-- | This solution guarantees that the finalizer is executed
--
test4 ∷ IO ()
test4 = checkLogs 4 $ do
    bracket_ (enter "main") (exit "main") $ do
        a ← async $ thread "a"
        threadDelay 100
        cancel a
        void $ waitCatch a

-- | This solution guarantees that the finalizer is executed
--
test5 ∷ IO ()
test5 = checkLogs 4 $ do
    bracket_ (enter "main") (exit "main") $ do
        withSafeAsync (thread "a") $ \_ →
            threadDelay 100

-- -------------------------------------------------------------------------- --
-- Tools

thread ∷ T.Text → IO ()
thread x = bracket_ (enter x) (exit x) (forever $ threadDelay 10)

threadWithMask ∷ T.Text → (IO () → IO ()) → IO ()
threadWithMask x restore = bracket_ (enter x) (exit x) (restore $ forever $ threadDelay 10)

enter ∷ T.Text → IO ()
enter x = logg $ "enter " ⊕ x

exit ∷ T.Text → IO ()
exit x = logg $ "exit " ⊕ x

-- | Alternative, less efficient, implementation of 'race'.
--
altRace_ ∷ IO a → IO b → IO ()
altRace_ left right =
    withAsync left $ \a →
    withAsync right $ \b →
        void (waitEither a b)

safeRace_ ∷ IO a → IO b → IO ()
safeRace_ left right =
    withSafeAsync left $ \a →
    withSafeAsync right $ \b →
        void (waitEither a b)

-- | The difference to the (non-optimized) implementation of
-- 'withAsync' is the 'wait' after the 'cancel'.
--
withSafeAsync ∷ IO a → (Async a → IO b) → IO b
withSafeAsync action inner =
    bracket (async action) (\a → cancel a ≫ waitCatch a) inner