1 {-# LANGUAGE BangPatterns #-} 2 {-# LANGUAGE CPP #-} 3 {-# LANGUAGE RankNTypes #-} 4 5 module 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) 16 import Control.Applicative ((<$>)) 17 #endif 18 import Control.Concurrent (MVar, ThreadId, killThread, newEmptyMVar, putMVar, readMVar) 19 #if MIN_VERSION_base(4,7,0) 20 import Control.Concurrent (tryReadMVar) 21 #else 22 import Control.Concurrent (tryTakeMVar) 23 import Control.Monad (when) 24 import Data.Maybe (fromJust, isJust) 25 #endif 26 import Control.Concurrent.Extended (forkIOLabeledWithUnmaskBs, forkOnLabeledWithUnmaskBs) 27 import qualified Control.Exception as E 28 import Control.Monad (void) 29 import qualified Data.ByteString.Char8 as B 30 import GHC.Exts (inline) 31 32 #if !MIN_VERSION_base(4,7,0) 33 tryReadMVar :: MVar a -> IO (Maybe a) 34 tryReadMVar mv = do 35 m <- tryTakeMVar mv 36 when (isJust m) $ putMVar mv (fromJust m) 37 return m 38 #endif 39 40 ------------------------------------------------------------------------------ 41 data SnapThread = SnapThread { 42 _snapThreadId :: {-# UNPACK #-} !ThreadId 43 , _snapThreadFinished :: {-# UNPACK #-} !(MVar ()) 44 } 45 46 instance Show SnapThread where 47 show = show . _snapThreadId 48 49 50 ------------------------------------------------------------------------------ 51 forkOn :: 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 56 forkOn 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 ------------------------------------------------------------------------------ 64 fork :: B.ByteString -- ^ thread label 65 -> ((forall a . IO a -> IO a) -> IO ()) -- ^ user thread action, taking 66 -- a restore function 67 -> IO SnapThread 68 fork 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 ------------------------------------------------------------------------------ 76 cancel :: SnapThread -> IO () 77 cancel = killThread . _snapThreadId 78 79 80 ------------------------------------------------------------------------------ 81 wait :: SnapThread -> IO () 82 wait = void . readMVar . _snapThreadFinished 83 84 85 ------------------------------------------------------------------------------ 86 cancelAndWait :: SnapThread -> IO () 87 cancelAndWait t = cancel t >> wait t 88 89 90 ------------------------------------------------------------------------------ 91 isFinished :: SnapThread -> IO Bool 92 isFinished t = 93 maybe False (const True) <$> tryReadMVar (_snapThreadFinished t) 94 95 96 ------------------------------------------------------------------------------ 97 -- Internal functions follow 98 ------------------------------------------------------------------------------ 99 wrapAction :: MVar () 100 -> ((forall a . IO a -> IO a) -> IO ()) 101 -> ((forall a . IO a -> IO a) -> IO ()) 102 wrapAction 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 $! ())