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 $! ())