-- |this module provides a simple mechanism for adding IO operations
-- to a queue and running them in a single thread. This is useful if
-- the IO operations have side-effects which could collide if run from
-- multiple threads. For example, creating an image thumbnail and
-- storing it on disk, running LaTeX, etc.
module Clckwrks.IOThread where

import Control.Concurrent (ThreadId, forkIO, killThread)
import Control.Concurrent.Chan (Chan,newChan, readChan, writeChan)
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)
import Control.Exception
import Control.Monad (forever)

data IOThread a b = IOThread { IOThread a b -> ThreadId
ioThreadId :: ThreadId
                             , IOThread a b -> Chan (a, MVar (Either SomeException b))
ioThreadChan :: (Chan (a, MVar (Either SomeException b)))
                             }

-- |start the IO thread.
startIOThread :: (a -> IO b) -- ^ the IO function that does all the work
              -> IO (IOThread a b) -- ^ a handle to the IOThread
startIOThread :: (a -> IO b) -> IO (IOThread a b)
startIOThread a -> IO b
f =
    do Chan (a, MVar (Either SomeException b))
c <- IO (Chan (a, MVar (Either SomeException b)))
forall a. IO (Chan a)
newChan
       ThreadId
tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (a -> IO b) -> Chan (a, MVar (Either SomeException b)) -> IO ()
forall e t a b.
Exception e =>
(t -> IO a) -> Chan (t, MVar (Either e a)) -> IO b
ioThread a -> IO b
f Chan (a, MVar (Either SomeException b))
c
       IOThread a b -> IO (IOThread a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (ThreadId -> Chan (a, MVar (Either SomeException b)) -> IOThread a b
forall a b.
ThreadId -> Chan (a, MVar (Either SomeException b)) -> IOThread a b
IOThread ThreadId
tid Chan (a, MVar (Either SomeException b))
c)
    where
      ioThread :: (t -> IO a) -> Chan (t, MVar (Either e a)) -> IO b
ioThread t -> IO a
f Chan (t, MVar (Either e a))
c =
          IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO b) -> IO () -> IO b
forall a b. (a -> b) -> a -> b
$ do (t
a, MVar (Either e a)
mvar) <- Chan (t, MVar (Either e a)) -> IO (t, MVar (Either e a))
forall a. Chan a -> IO a
readChan Chan (t, MVar (Either e a))
c
                       Either e a
b <- IO a -> IO (Either e a)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO a -> IO (Either e a)) -> IO a -> IO (Either e a)
forall a b. (a -> b) -> a -> b
$ t -> IO a
f t
a
                       MVar (Either e a) -> Either e a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either e a)
mvar Either e a
b

-- |kill the IOThread
--
-- WARNING: no attempt is made to wait for the queue to empty... we should probably have safer version that waits for the operations to complete?
killIOThread :: IOThread a b -> IO ()
killIOThread :: IOThread a b -> IO ()
killIOThread IOThread a b
iot = ThreadId -> IO ()
killThread (IOThread a b -> ThreadId
forall a b. IOThread a b -> ThreadId
ioThreadId IOThread a b
iot)

-- |issue a request to the IO thread and get back the result
-- if the thread function throws an exception 'ioRequest' will rethrow the exception.
ioRequest :: (IOThread a b) -- ^ handle to the IOThread
          -> a -- ^ argument to the function in the IOThread
          -> IO b -- ^ value returned by the function in the IOThread
ioRequest :: IOThread a b -> a -> IO b
ioRequest IOThread a b
iot a
a =
    do MVar (Either SomeException b)
resp <- IO (MVar (Either SomeException b))
forall a. IO (MVar a)
newEmptyMVar
       Chan (a, MVar (Either SomeException b))
-> (a, MVar (Either SomeException b)) -> IO ()
forall a. Chan a -> a -> IO ()
writeChan (IOThread a b -> Chan (a, MVar (Either SomeException b))
forall a b. IOThread a b -> Chan (a, MVar (Either SomeException b))
ioThreadChan IOThread a b
iot) (a
a, MVar (Either SomeException b)
resp)
       Either SomeException b
e <- MVar (Either SomeException b) -> IO (Either SomeException b)
forall a. MVar a -> IO a
readMVar MVar (Either SomeException b)
resp
       case Either SomeException b
e of
         (Right b
r) ->  b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
r
         (Left SomeException
err) -> SomeException -> IO b
forall e a. Exception e => e -> IO a
throwIO SomeException
err