{-# LANGUAGE CPP #-}

-- | In a multithreaded environment, running actions on a regularly scheduled
-- background thread can dramatically improve performance.
-- For example, web servers need to return the current time with each HTTP response.
-- For a high-volume server, it's much faster for a dedicated thread to run every
-- second, and write the current time to a shared 'IORef', than it is for each
-- request to make its own call to 'getCurrentTime'.
--
-- But for a low-volume server, whose request frequency is less than once per
-- second, that approach will result in /more/ calls to 'getCurrentTime' than
-- necessary, and worse, kills idle GC.
--
-- This library solves that problem by allowing you to define actions which will
-- either be performed by a dedicated thread, or, in times of low volume, will
-- be executed by the calling thread.
--
-- Example usage:
--
-- @
-- import "Data.Time"
-- import "Control.AutoUpdate"
--
-- getTime <- 'mkAutoUpdate' 'defaultUpdateSettings'
--              { 'updateAction' = 'Data.Time.Clock.getCurrentTime'
--              , 'updateFreq' = 1000000 -- The default frequency, once per second
--              }
-- currentTime <- getTime
-- @
--
-- For more examples, <http://www.yesodweb.com/blog/2014/08/announcing-auto-update see the blog post introducing this library>.
module Control.AutoUpdate (
    -- * Type
    UpdateSettings,
    defaultUpdateSettings,

    -- * Accessors
    updateAction,
    updateFreq,
    updateSpawnThreshold,
    updateThreadName,

    -- * Creation
    mkAutoUpdate,
    mkAutoUpdateWithModify,
) where

#if __GLASGOW_HASKELL__ < 709
import           Control.Applicative     ((<*>))
#endif
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar (
    newEmptyMVar,
    putMVar,
    readMVar,
    takeMVar,
    tryPutMVar,
 )
import Control.Exception (
    SomeException,
    catch,
    mask_,
    throw,
    try,
 )
import Control.Monad (void)
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.Maybe (fromMaybe)
import GHC.Conc.Sync (labelThread)

-- | Default value for creating an 'UpdateSettings'.
--
-- @since 0.1.0
defaultUpdateSettings :: UpdateSettings ()
defaultUpdateSettings :: UpdateSettings ()
defaultUpdateSettings =
    UpdateSettings
        { updateFreq :: Int
updateFreq = Int
1000000
        , updateSpawnThreshold :: Int
updateSpawnThreshold = Int
3
        , updateAction :: IO ()
updateAction = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        , updateThreadName :: String
updateThreadName = String
"AutoUpdate"
        }

-- | Settings to control how values are updated.
--
-- This should be constructed using 'defaultUpdateSettings' and record
-- update syntax, e.g.:
--
-- @
-- let settings = 'defaultUpdateSettings' { 'updateAction' = 'Data.Time.Clock.getCurrentTime' }
-- @
--
-- @since 0.1.0
data UpdateSettings a = UpdateSettings
    { forall a. UpdateSettings a -> Int
updateFreq :: Int
    -- ^ Microseconds between update calls. Same considerations as
    -- 'threadDelay' apply.
    --
    -- Default: 1 second (1000000)
    --
    -- @since 0.1.0
    , forall a. UpdateSettings a -> Int
updateSpawnThreshold :: Int
    -- ^ NOTE: This value no longer has any effect, since worker threads are
    -- dedicated instead of spawned on demand.
    --
    -- Previously, this determined how many times the data must be requested
    -- before we decide to spawn a dedicated thread.
    --
    -- Default: 3
    --
    -- @since 0.1.0
    , forall a. UpdateSettings a -> IO a
updateAction :: IO a
    -- ^ Action to be performed to get the current value.
    --
    -- Default: does nothing.
    --
    -- @since 0.1.0
    , forall a. UpdateSettings a -> String
updateThreadName :: String
    }

-- | Generate an action which will either read from an automatically
-- updated value, or run the update action in the current thread.
--
-- @since 0.1.0
mkAutoUpdate :: UpdateSettings a -> IO (IO a)
mkAutoUpdate :: forall a. UpdateSettings a -> IO (IO a)
mkAutoUpdate UpdateSettings a
us = UpdateSettings a -> Maybe (a -> IO a) -> IO (IO a)
forall a. UpdateSettings a -> Maybe (a -> IO a) -> IO (IO a)
mkAutoUpdateHelper UpdateSettings a
us Maybe (a -> IO a)
forall a. Maybe a
Nothing

-- | Generate an action which will either read from an automatically
-- updated value, or run the update action in the current thread if
-- the first time or the provided modify action after that.
--
-- @since 0.1.4
mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a)
mkAutoUpdateWithModify :: forall a. UpdateSettings a -> (a -> IO a) -> IO (IO a)
mkAutoUpdateWithModify UpdateSettings a
us a -> IO a
f = UpdateSettings a -> Maybe (a -> IO a) -> IO (IO a)
forall a. UpdateSettings a -> Maybe (a -> IO a) -> IO (IO a)
mkAutoUpdateHelper UpdateSettings a
us ((a -> IO a) -> Maybe (a -> IO a)
forall a. a -> Maybe a
Just a -> IO a
f)

mkAutoUpdateHelper :: UpdateSettings a -> Maybe (a -> IO a) -> IO (IO a)
mkAutoUpdateHelper :: forall a. UpdateSettings a -> Maybe (a -> IO a) -> IO (IO a)
mkAutoUpdateHelper UpdateSettings a
us Maybe (a -> IO a)
updateActionModify = do
    -- A baton to tell the worker thread to generate a new value.
    MVar ()
needsRunning <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

    -- The initial response variable. Response variables allow the requesting
    -- thread to block until a value is generated by the worker thread.
    MVar a
responseVar0 <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar

    -- The current value, if available. We start off with a Left value
    -- indicating no value is available, and the above-created responseVar0 to
    -- give a variable to block on.
    IORef (Either (MVar a) a)
currRef <- Either (MVar a) a -> IO (IORef (Either (MVar a) a))
forall a. a -> IO (IORef a)
newIORef (Either (MVar a) a -> IO (IORef (Either (MVar a) a)))
-> Either (MVar a) a -> IO (IORef (Either (MVar a) a))
forall a b. (a -> b) -> a -> b
$ MVar a -> Either (MVar a) a
forall a b. a -> Either a b
Left MVar a
responseVar0

    -- This is used to set a value in the currRef variable when the worker
    -- thread exits. In reality, that value should never be used, since the
    -- worker thread exiting only occurs if an async exception is thrown, which
    -- should only occur if there are no references to needsRunning left.
    -- However, this handler will make error messages much clearer if there's a
    -- bug in the implementation.
    let fillRefOnExit :: IO () -> IO ()
fillRefOnExit IO ()
f = do
            Either SomeException ()
eres <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try IO ()
f
            case Either SomeException ()
eres of
                Left SomeException
e ->
                    IORef (Either (MVar a) a) -> Either (MVar a) a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Either (MVar a) a)
currRef (Either (MVar a) a -> IO ()) -> Either (MVar a) a -> IO ()
forall a b. (a -> b) -> a -> b
$
                        String -> Either (MVar a) a
forall a. HasCallStack => String -> a
error (String -> Either (MVar a) a) -> String -> Either (MVar a) a
forall a b. (a -> b) -> a -> b
$
                            String
"Control.AutoUpdate.mkAutoUpdate: worker thread exited with exception: "
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show (SomeException
e :: SomeException)
                Right () ->
                    IORef (Either (MVar a) a) -> Either (MVar a) a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Either (MVar a) a)
currRef (Either (MVar a) a -> IO ()) -> Either (MVar a) a -> IO ()
forall a b. (a -> b) -> a -> b
$
                        String -> Either (MVar a) a
forall a. HasCallStack => String -> a
error (String -> Either (MVar a) a) -> String -> Either (MVar a) a
forall a b. (a -> b) -> a -> b
$
                            String
"Control.AutoUpdate.mkAutoUpdate: worker thread exited normally, "
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"which should be impossible due to usage of infinite loop"

    -- fork the worker thread immediately. Note that we mask async exceptions,
    -- but *not* in an uninterruptible manner. This will allow a
    -- BlockedIndefinitelyOnMVar exception to still be thrown, which will take
    -- down this thread when all references to the returned function are
    -- garbage collected, and therefore there is no thread that can fill the
    -- needsRunning MVar.
    --
    -- Note that since we throw away the ThreadId of this new thread and never
    -- calls myThreadId, normal async exceptions can never be thrown to it,
    -- only RTS exceptions.
    ThreadId
tid <- IO ThreadId -> IO ThreadId
forall a. IO a -> IO a
mask_ (IO ThreadId -> IO ThreadId) -> IO ThreadId -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
fillRefOnExit (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        -- This infinite loop makes up out worker thread. It takes an a
        -- responseVar value where the next value should be putMVar'ed to for
        -- the benefit of any requesters currently blocked on it.
        let loop :: MVar a -> Maybe a -> IO b
loop MVar a
responseVar Maybe a
maybea = do
                -- block until a value is actually needed
                MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
needsRunning

                -- new value requested, so run the updateAction
                a
a <- IO a -> IO a
forall a. IO a -> IO a
catchSome (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> Maybe (IO a) -> IO a
forall a. a -> Maybe a -> a
fromMaybe (UpdateSettings a -> IO a
forall a. UpdateSettings a -> IO a
updateAction UpdateSettings a
us) (Maybe (a -> IO a)
updateActionModify Maybe (a -> IO a) -> Maybe a -> Maybe (IO a)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe a
maybea)

                -- we got a new value, update currRef and lastValue
                IORef (Either (MVar a) a) -> Either (MVar a) a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Either (MVar a) a)
currRef (Either (MVar a) a -> IO ()) -> Either (MVar a) a -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> Either (MVar a) a
forall a b. b -> Either a b
Right a
a
                MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
responseVar a
a

                -- delay until we're needed again
                Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ UpdateSettings a -> Int
forall a. UpdateSettings a -> Int
updateFreq UpdateSettings a
us

                -- delay's over. create a new response variable and set currRef
                -- to use it, so that the next requester will block on that
                -- variable. Then loop again with the updated response
                -- variable.
                MVar a
responseVar' <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
                IORef (Either (MVar a) a) -> Either (MVar a) a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Either (MVar a) a)
currRef (Either (MVar a) a -> IO ()) -> Either (MVar a) a -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar a -> Either (MVar a) a
forall a b. a -> Either a b
Left MVar a
responseVar'
                MVar a -> Maybe a -> IO b
loop MVar a
responseVar' (a -> Maybe a
forall a. a -> Maybe a
Just a
a)

        -- Kick off the loop, with the initial responseVar0 variable.
        MVar a -> Maybe a -> IO ()
forall {b}. MVar a -> Maybe a -> IO b
loop MVar a
responseVar0 Maybe a
forall a. Maybe a
Nothing
    ThreadId -> String -> IO ()
labelThread ThreadId
tid (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ UpdateSettings a -> String
forall a. UpdateSettings a -> String
updateThreadName UpdateSettings a
us
    IO a -> IO (IO a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO a -> IO (IO a)) -> IO a -> IO (IO a)
forall a b. (a -> b) -> a -> b
$ do
        Either (MVar a) a
mval <- IORef (Either (MVar a) a) -> IO (Either (MVar a) a)
forall a. IORef a -> IO a
readIORef IORef (Either (MVar a) a)
currRef
        case Either (MVar a) a
mval of
            Left MVar a
responseVar -> do
                -- no current value, force the worker thread to run...
                IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
needsRunning ()

                -- and block for the result from the worker
                MVar a -> IO a
forall a. MVar a -> IO a
readMVar MVar a
responseVar
            -- we have a current value, use it
            Right a
val -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val

-- | Turn a runtime exception into an impure exception, so that all 'IO'
-- actions will complete successfully. This simply defers the exception until
-- the value is forced.
catchSome :: IO a -> IO a
catchSome :: forall a. IO a -> IO a
catchSome IO a
act = IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Control.Exception.catch IO a
act ((SomeException -> IO a) -> IO a)
-> (SomeException -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \SomeException
e -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ SomeException -> a
forall a e. Exception e => e -> a
throw (SomeException
e :: SomeException)