1{-# LANGUAGE BangPatterns #-} 2{-# LANGUAGE CPP #-} 3{-# LANGUAGE RankNTypes #-} 4 5module Snap.Internal.Http.Server.Thread 6 ( SnapThread 7 , fork 8 , forkOn 9 , cancel 10 , wait 11 , cancelAndWait 12 , isFinished 13 ) where 14 15#if !MIN_VERSION_base(4,8,0) 16import Control.Applicative ((<$>)) 17#endif 18import Control.Concurrent (MVar, ThreadId, killThread, newEmptyMVar, putMVar, readMVar) 19#if MIN_VERSION_base(4,7,0) 20import Control.Concurrent (tryReadMVar) 21#else 22import Control.Concurrent (tryTakeMVar) 23import Control.Monad (when) 24import Data.Maybe (fromJust, isJust) 25#endif 26import Control.Concurrent.Extended (forkIOLabeledWithUnmaskBs, forkOnLabeledWithUnmaskBs) 27import qualified Control.Exception as E 28import Control.Monad (void) 29import qualified Data.ByteString.Char8 as B 30import GHC.Exts (inline) 31 32#if !MIN_VERSION_base(4,7,0) 33tryReadMVar :: MVar a -> IO (Maybe a) 34tryReadMVar mv = do 35 m <- tryTakeMVar mv 36 when (isJust m) $ putMVar mv (fromJust m) 37 return m 38#endif 39 40------------------------------------------------------------------------------ 41data SnapThread = SnapThread { 42 _snapThreadId :: {-# UNPACK #-} !ThreadId 43 , _snapThreadFinished :: {-# UNPACK #-} !(MVar ()) 44 } 45 46instance Show SnapThread where 47 show = show . _snapThreadId 48 49 50------------------------------------------------------------------------------ 51forkOn :: B.ByteString -- ^ thread label 52 -> Int -- ^ capability 53 -> ((forall a . IO a -> IO a) -> IO ()) -- ^ user thread action, taking 54 -- a restore function 55 -> IO SnapThread 56forkOn label cap action = do 57 mv <- newEmptyMVar 58 E.uninterruptibleMask_ $ do 59 tid <- forkOnLabeledWithUnmaskBs label cap (wrapAction mv action) 60 return $! SnapThread tid mv 61 62 63------------------------------------------------------------------------------ 64fork :: B.ByteString -- ^ thread label 65 -> ((forall a . IO a -> IO a) -> IO ()) -- ^ user thread action, taking 66 -- a restore function 67 -> IO SnapThread 68fork label action = do 69 mv <- newEmptyMVar 70 E.uninterruptibleMask_ $ do 71 tid <- forkIOLabeledWithUnmaskBs label (wrapAction mv action) 72 return $! SnapThread tid mv 73 74 75------------------------------------------------------------------------------ 76cancel :: SnapThread -> IO () 77cancel = killThread . _snapThreadId 78 79 80------------------------------------------------------------------------------ 81wait :: SnapThread -> IO () 82wait = void . readMVar . _snapThreadFinished 83 84 85------------------------------------------------------------------------------ 86cancelAndWait :: SnapThread -> IO () 87cancelAndWait t = cancel t >> wait t 88 89 90------------------------------------------------------------------------------ 91isFinished :: SnapThread -> IO Bool 92isFinished t = 93 maybe False (const True) <$> tryReadMVar (_snapThreadFinished t) 94 95 96------------------------------------------------------------------------------ 97-- Internal functions follow 98------------------------------------------------------------------------------ 99wrapAction :: MVar () 100 -> ((forall a . IO a -> IO a) -> IO ()) 101 -> ((forall a . IO a -> IO a) -> IO ()) 102wrapAction mv action restore = (action restore >> inline exit) `E.catch` onEx 103 where 104 onEx :: E.SomeException -> IO () 105 onEx !_ = inline exit 106 107 exit = E.uninterruptibleMask_ (putMVar mv $! ()) 108