Threading.hs

-- ----------------------------------------------------------------------------

{- |
  Module     : Holumbus.Common.Threading
  Copyright  : Copyright (C) 2008 Stefan Schmidt
  License    : MIT

  Maintainer : Stefan Schmidt (stefanschmidt@web.de)
  Stability  : experimental
  Portability: portable
  Version    : 0.1

  Operations to start and stop threads which will not be killed when a regular
  exception occurs. In this case, the thread will continue working. Such a 
  thread can only be killed by the stop-method. This whole thing is a wrapper
  around the normal lightweight thread functions.
  
  The created threads execute a function in an infinite loop. This is the
  normal usecase for message dispatcher threads.
  
-}

-- ----------------------------------------------------------------------------

module Holumbus.Common.Threading
(
  Thread
, newThread
, setThreadDelay
, setThreadAction
, setThreadErrorHandler

, startThread
, stopThread
)
where

{- 6.8
import qualified Control.Exception      as E
import           Data.Typeable
-}
import           Control.Exception      ( AsyncException(..)
                                        , catchJust
                                        )
import           Control.Concurrent

import           Data.Maybe

import           System.Log.Logger

import           Holumbus.Common.Utils  ( handleAll )

localLogger :: String
localLogger = "Holumbus.Common.Threading"


-- ----------------------------------------------------------------------------
-- Thread-Control
-- ----------------------------------------------------------------------------

-- | Exception to stop a thread, so we can distinguish this request from
--   "real" exceptions.

{- 6.8
data KillThreadException = KillThreadException ThreadId
  deriving (Typeable, Show)
-}

-- | The data needed to access and control the thread. 
data ThreadData = ThreadData {
    thd_Id      :: Maybe ThreadId
  , thd_Running :: Bool
  , thd_Delay   :: Maybe Int
  , thd_Action  :: (IO ())
  , thd_Error   :: (IO ())
  }
  
  
-- | The thread datatype
type Thread = MVar ThreadData 


-- | Creates a new thread object. The thread will not be running.
newThread :: IO Thread
newThread
  = do 
    newMVar $ ThreadData Nothing False defaultDelay noAction noAction
    where
    noAction     = return ()
    defaultDelay = Nothing


-- | Sets the delay between two loop cycles. Default value: no delay.
setThreadDelay :: Int -> Thread -> IO ()
setThreadDelay d thread
  = do
    modifyMVar thread $ \thd -> return (thd {thd_Delay = Just d},())
    
    
-- | Sets the action function, which will be executed in each cycle
setThreadAction :: (IO ()) -> Thread -> IO ()
setThreadAction f thread
  = do
    modifyMVar thread $ \thd -> return (thd {thd_Action = f},())


-- | Sets the error handler. It is activated, when the action function
--   will raise an exception.
setThreadErrorHandler :: (IO ()) -> Thread -> IO ()
setThreadErrorHandler e thread
  = do
    modifyMVar thread $ \thd -> return (thd {thd_Error = e},())


-- | Starts the thread.
startThread :: Thread -> IO ()
startThread th
  = modifyMVar th $
      \thd ->
      do
      -- check, if thread is running (it has a threadId)
      servId' <- case (thd_Id thd) of
        i@(Just _) -> return i
        (Nothing) ->
          do
          -- if not running, start the loop
          i <- forkIO $ doAction th
          return (Just i)
      return (thd {thd_Id = servId', thd_Running = True},())
    where    
    -- the action loop
    doAction thread
      = do
        thd <- readMVar thread
        if (thd_Running thd)
          -- if thread is still running 
          then do
            {- 6.8 E.handle -}
            handleAll
             ( \ e -> do
                      -- if a normal exception occurs, the error handler should be excuted
                      warningM localLogger $ show e
                      thd_Error thd
                      doAction thread
             ) $
              do
              -- catch the exception which tells us to kill the dispatcher and kill it
              {- 6.8 E.catchDyn -}
              catchJust isThreadKilledException
               ( do
                 -- wait for next watch-cycle
                 if (isJust (thd_Delay thd)) 
                    then do threadDelay $ fromJust (thd_Delay thd)
                    else do return ()
                 -- do the action
                 thd_Action thd
                 -- and again
                 doAction thread
               )
               killHandler
          else do
            debugM localLogger $ "thread normally closed by himself"
            deleteThreadId thread
	where
        isThreadKilledException      		:: AsyncException -> Maybe ()
        isThreadKilledException ThreadKilled    = Just ()
        isThreadKilledException _               = Nothing

        killHandler :: () -> IO ()
        killHandler _
          = do
            debugM localLogger $ "thread normally closed by other thread "
            deleteThreadId thread
{- 6.8
        killHandler :: KillThreadException -> IO ()
        killHandler (KillThreadException i)
          = do
            debugM localLogger $ "thread normally closed by other thread " ++ show i
            deleteThreadId thread
-}
        deleteThreadId :: Thread -> IO ()
        deleteThreadId t
          = modifyMVar t $ \thd -> return (thd {thd_Id = Nothing, thd_Running = False},())


-- | Stops the thread. If the thread itself wants to stop from within the action
--   function, the current cycle will be executed till the end. So statements
--   after this function will still be executed.
stopThread :: Thread -> IO ()
stopThread thread
  = do
    me <- myThreadId
    him <- withMVar thread $ \thd -> return $ thd_Id thd
    if (isJust him) 
      then do
        let he = fromJust him
        if (me == he) 
          -- if stop is called from the thread, we want to finish our work
          then do 
            modifyMVar thread $ \thd -> return (thd {thd_Running = False},())
            -- else we kill it the unfriendly way...
          else do
            {- 6.8: E.throwDynTo he (KillThreadException me) -}
            killThread he
      else do
        return ()