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