diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Moritz Schulte (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Moritz Schulte nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,38 @@ +# async-refresh + +About +===== + +This is Haskell library implementing the logic for refreshing of +expiring data according to user-provided actions. + +Usage +===== + +- Create a new configuration using `newAsyncRefreshConf`, providing + the action to be used for data refreshing. + +- Adjust the configuration using the `asyncRefreshConfSet*` functions, + in particular using `asyncRefreshConfSetCallback`. + +- Use `newAsyncRefresh` to initiate a new thread managing the + asynchronous refreshing. + +Example +======= + +The following IO action produces a `TVar` which is updated every ten +seconds to contain the current time (wrapped in an `Either +SomeException`, because refreshing may fail). + +``` +periodicTimeUpdater :: IO (TVar (Either SomeException UTCTime)) +periodicTimeUpdater = runStderrLoggingT $ do + timeStore <- liftIO $ newTVarIO (Left (toException NotFound)) + let conf = newAsyncRefreshConf (RefreshResult <$> liftIO getCurrentTime <*> pure Nothing) + & asyncRefreshConfSetLabel "CurrentTime updated every 10 seconds" + & asyncRefreshConfSetDefaultInterval (10 * 10^3) + & asyncRefreshConfSetCallback (liftIO . atomically . writeTVar timeStore . fmap refreshResult) + _ <- newAsyncRefresh conf + return timeStore +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/async-refresh.cabal b/async-refresh.cabal new file mode 100644 --- /dev/null +++ b/async-refresh.cabal @@ -0,0 +1,62 @@ +name: async-refresh +version: 0.1.7 +synopsis: Package implementing core logic for refreshing of expiring data. +description: This package can be used for refreshing of expiring data according + to a user-provided action. Using callbacks, the user can decide + how she or he would like to be informed about data refreshing. +homepage: https://github.com/mtesseract/async-refresh +license: BSD3 +license-file: LICENSE +author: Moritz Schulte +maintainer: mtesseract@silverratio.net +copyright: (c) 2017 Moritz Schulte +category: Control +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Control.Concurrent.Async.Refresh + other-modules: Control.Concurrent.Async.Refresh.Prelude + , Control.Concurrent.Async.Refresh.Util + , Control.Concurrent.Async.Refresh.Types + , Control.Concurrent.Async.Refresh.Lenses + build-depends: base >= 4.7 && < 5 + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-type-defaults + other-extensions: NoImplicitPrelude + , OverloadedStrings + , RecordWildCards + , FlexibleContexts + , MultiParamTypeClasses + build-depends: base >= 4.7 && < 5 + , text + , lens + , monad-logger + , lifted-async + , stm + , safe-exceptions + , formatting + , monad-control + +test-suite async-refresh-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , async-refresh + , text + , HUnit + , test-framework + , test-framework-hunit + , criterion + , monad-logger + , stm + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + default-extensions: OverloadedStrings + +source-repository head + type: git + location: https://github.com/mtesseract/async-refresh diff --git a/src/Control/Concurrent/Async/Refresh.hs b/src/Control/Concurrent/Async/Refresh.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Async/Refresh.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +{-| +Module : Control.Concurrent.Async.Refresh +Description : This module exposes the API of the async-refresh package. +Copyright : (c) Moritz Schulte, 2017 +License : BSD3 +Maintainer : mtesseract@silverratio.net +Stability : experimental +Portability : POSIX + +The async-refresh package provides the logic for periodic refreshing +of arbitrary data. This module implements the core of the package and +exposes its API. +-} + +module Control.Concurrent.Async.Refresh + ( AsyncRefreshConf + , AsyncRefresh + , AsyncRefreshCallback + , RefreshResult(..) + , defaultAsyncRefreshInterval + , newAsyncRefreshConf + , asyncRefreshConfSetDefaultInterval + , asyncRefreshConfSetLabel + , asyncRefreshConfSetFactor + , asyncRefreshConfSetCallback + , newAsyncRefresh + , asyncRefreshAsync + ) where + +import Control.Concurrent.Async.Refresh.Prelude +import Control.Concurrent.Async.Lifted.Safe (wait) +import qualified Control.Concurrent.Async.Refresh.Lenses as Lens +import Control.Concurrent.Async.Refresh.Types +import Control.Concurrent.Async.Refresh.Util +import Control.Lens + +-- | Given a refresh action, create a new configuration. +newAsyncRefreshConf :: MonadIO m => m (RefreshResult a) -> AsyncRefreshConf m a +newAsyncRefreshConf action = + AsyncRefreshConf { _asyncRefreshConfDefaultInterval = defaultAsyncRefreshInterval + , _asyncRefreshConfAction = action + , _asyncRefreshConfCallback = defaultAsyncRefreshCallback + , _asyncRefreshConfLabel = defaultAsyncRefreshLabel + , _asyncRefreshConfFactor = defaultAsyncRefreshFactor } + +-- | Default refresh interval is one minute (in milliseconds). +defaultAsyncRefreshInterval :: Int +defaultAsyncRefreshInterval = 60 * 10^3 + +-- | Default refresh factor. See documentation for 'asyncRefreshConfSetFactor'. +defaultAsyncRefreshFactor :: Double +defaultAsyncRefreshFactor = 0.8 + +-- | The default refresh callback is a no-op. +defaultAsyncRefreshCallback :: Monad m => Either SomeException (RefreshResult a) -> m () +defaultAsyncRefreshCallback _ = return () + +-- | The default label for configuration is 'Nothing'. +defaultAsyncRefreshLabel :: Maybe Text +defaultAsyncRefreshLabel = Nothing + +-- | Set default refresh interval, specified in milliseconds, in the +-- given configuration. If a refresh action fails or does not produce +-- an expiry time, this interval will be used. +asyncRefreshConfSetDefaultInterval :: Int + -> AsyncRefreshConf m a + -> AsyncRefreshConf m a +asyncRefreshConfSetDefaultInterval = (Lens.defaultInterval .~) + +-- | Set the label in the provided configuration. This is a human +-- readable text, used for logging purposes. +asyncRefreshConfSetLabel :: Text + -> AsyncRefreshConf m a + -> AsyncRefreshConf m a +asyncRefreshConfSetLabel label = Lens.label .~ Just label + +-- | Extract a human readable label from the provided configuration. +asyncRefreshConfGetLabel :: AsyncRefreshConf m a -> Text +asyncRefreshConfGetLabel conf = fromMaybe "Nothing" (conf ^. Lens.label) + +-- | Set the refresh factor. When a refresh gives an explicit expiry +-- time after a succesful refresh run, then this expiry time will be +-- multiplied by this factor, yielding the effective expiry time after +-- which a new refresh run will be scheduled. +asyncRefreshConfSetFactor :: Double + -> AsyncRefreshConf m a + -> AsyncRefreshConf m a +asyncRefreshConfSetFactor factor = Lens.factor .~ restrictToInterval 0 1 factor + +-- | Set a refresh callback for the provided configuration. This +-- callback will be called after a refresh run. +asyncRefreshConfSetCallback :: AsyncRefreshCallback m a + -> AsyncRefreshConf m a + -> AsyncRefreshConf m a +asyncRefreshConfSetCallback = (Lens.callback .~) + +-- | Start a new thread taking care of refreshing of data according to +-- the given configuration. +newAsyncRefresh :: ( MonadIO m + , MonadBaseControl IO m + , MonadCatch m + , MonadMask m + , MonadLogger m + , Forall (Pure m) ) + => AsyncRefreshConf m a + -> m AsyncRefresh +newAsyncRefresh conf = AsyncRefresh <$> async (asyncRefreshCtrlThread conf) + +-- | Main function of the refresh control thread. Acts as a simple +-- watchdog for the thread defined by 'asyncRefreshThread' doing the +-- actual work. +asyncRefreshCtrlThread :: ( MonadIO m + , MonadBaseControl IO m + , MonadCatch m + , MonadMask m + , MonadLogger m + , Forall (Pure m) ) + => AsyncRefreshConf m a + -> m () +asyncRefreshCtrlThread conf = do + withAsync (asyncRefreshThread conf) $ \asyncHandle -> wait asyncHandle + logErrorN "Unexpected termination of async refresh thread" + +-- | Main function for the thread implementing the refreshing logic. +asyncRefreshThread :: ( MonadIO m + , MonadBaseControl IO m + , MonadCatch m + , MonadLogger m + , Forall (Pure m) ) + => AsyncRefreshConf m a -> m () +asyncRefreshThread conf = forever $ + tryAny (asyncRefreshDo conf) >>= \case + Right res -> do + let delay = fromMaybe (conf ^. Lens.defaultInterval) (refreshTryNext res) + logDebugN $ + sformat ("Refreshing done for refreshing request '" % stext % "'") + (asyncRefreshConfGetLabel conf) + threadDelay (computeRefreshTime conf delay * 10^3) + Left exn -> do + logErrorN $ + sformat ("Refresh action failed for token request '" % stext % "': " % stext) + (asyncRefreshConfGetLabel conf) (tshow exn) + threadDelay (conf ^. Lens.defaultInterval * 10^3) + +-- | This function does the actual refreshing work. +asyncRefreshDo :: ( MonadIO m + , MonadBaseControl IO m + , MonadCatch m + , MonadLogger m + , Forall (Pure m) ) + => AsyncRefreshConf m a -> m (RefreshResult a) +asyncRefreshDo conf = do + tryA <- tryAny (conf ^. Lens.action) + `logOnError` sformat ("Failed to execute refresh action for token request '" + % stext % "'") (asyncRefreshConfGetLabel conf) + void $ tryAny ((conf ^. Lens.callback) tryA) + `logOnError` "User provided callback threw exception" + either throw return tryA + +-- | Scale the given duration according to the factor specified in the +-- configuration. +computeRefreshTime :: AsyncRefreshConf m a -> Int -> Int +computeRefreshTime conf duration = + floor $ (conf ^. Lens.factor) * fromIntegral duration diff --git a/src/Control/Concurrent/Async/Refresh/Lenses.hs b/src/Control/Concurrent/Async/Refresh/Lenses.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Async/Refresh/Lenses.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Control.Concurrent.Async.Refresh.Lenses where + +{-| +Module : Control.Concurrent.Async.Refresh.Lenses +Description : This module defines lenses used within the async-refresh package. +Copyright : (c) Moritz Schulte, 2017 +License : BSD3 +Maintainer : mtesseract@silverratio.net +Stability : experimental +Portability : POSIX +-} + +import Control.Concurrent.Async.Refresh.Types +import Control.Lens + +makeFields ''AsyncRefreshConf diff --git a/src/Control/Concurrent/Async/Refresh/Prelude.hs b/src/Control/Concurrent/Async/Refresh/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Async/Refresh/Prelude.hs @@ -0,0 +1,54 @@ +{-| +Module : Control.Concurrent.Async.Refresh.Prelude +Description : Prelude for the async-refresh package. +Copyright : (c) Moritz Schulte, 2017 +License : BSD3 +Maintainer : mtesseract@silverratio.net +Stability : experimental +Portability : POSIX +-} + +module Control.Concurrent.Async.Refresh.Prelude + ( module Prelude + , module Control.Exception.Safe + , module Formatting + , module Control.Monad.Logger + , Text + , fromMaybe + , Async, Forall, Pure, withAsync, async + , threadDelay + , forever, void + , MonadIO + , MonadBaseControl + , undefined + , tshow + ) where + +import qualified Control.Concurrent +import Control.Concurrent.Async.Lifted.Safe +import Control.Exception.Safe +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Logger +import Control.Monad.Trans.Control +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text +import Formatting +import Prelude hiding (head, tail, + undefined) +import qualified Prelude as Prelude + +-- | Version of 'undefined' with a deprecated pragma. +undefined :: a +undefined = Prelude.undefined +{-# DEPRECATED undefined "Don't use 'undefined' in production code" #-} + +-- | Modern version of 'Prelude.show' producing 'Text' instead of +-- 'String'. +tshow :: Show a => a -> Text +tshow = Data.Text.pack . show + +-- | Generalization of 'Control.Concurrent.threadDelay'. +threadDelay :: MonadIO m => Int -> m () +threadDelay = liftIO . Control.Concurrent.threadDelay diff --git a/src/Control/Concurrent/Async/Refresh/Types.hs b/src/Control/Concurrent/Async/Refresh/Types.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Async/Refresh/Types.hs @@ -0,0 +1,36 @@ +{-| +Module : Control.Concurrent.Async.Refresh.Types +Description : This module contains the type definitions for the async-refresh package. +Copyright : (c) Moritz Schulte, 2017 +License : BSD3 +Maintainer : mtesseract@silverratio.net +Stability : experimental +Portability : POSIX +-} + +module Control.Concurrent.Async.Refresh.Types where + +import Control.Concurrent.Async.Refresh.Prelude + +-- | Type synonym for async refresh callbacks. +type AsyncRefreshCallback m a = Either SomeException (RefreshResult a) -> m () + +-- | Data type defining an async refresh configuration. +data AsyncRefreshConf m a = + AsyncRefreshConf + { _asyncRefreshConfDefaultInterval :: Int -- ^ In milliseconds. + , _asyncRefreshConfAction :: m (RefreshResult a) -- ^ Action implementing the refreshing. + , _asyncRefreshConfFactor :: Double -- ^ Refresh factor. + , _asyncRefreshConfCallback :: AsyncRefreshCallback m a -- ^ To be called after refreshing. + , _asyncRefreshConfLabel :: Maybe Text -- ^ Human readable label. + } + +-- | Data type denoting a running async refresher. +data AsyncRefresh = + AsyncRefresh { asyncRefreshAsync :: Async () } + +-- | Data type returned by async refresh actions. +data RefreshResult a = + RefreshResult { refreshResult :: a -- ^ Actual result. + , refreshTryNext :: Maybe Int -- ^ In milliseconds. + } deriving (Show) diff --git a/src/Control/Concurrent/Async/Refresh/Util.hs b/src/Control/Concurrent/Async/Refresh/Util.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Async/Refresh/Util.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Control.Concurrent.Async.Refresh.Util +Description : This module contains utility functions used within the async-refresh package. +Copyright : (c) Moritz Schulte, 2017 +License : BSD3 +Maintainer : mtesseract@silverratio.net +Stability : experimental +Portability : POSIX +-} + +module Control.Concurrent.Async.Refresh.Util where + +import Control.Concurrent.Async.Refresh.Prelude + +-- | Helper function, which evaluates the given action, logging an +-- error in case of exceptions (and rethrowing the exception). +logOnError :: ( MonadIO m + , MonadCatch m + , MonadLogger m ) + => m a -> Text -> m a +logOnError ma msg = + let exnFormatter exn = sformat (stext % ": " % stext) msg (tshow exn) + in ma `catchAny` (\e -> logErrorN (exnFormatter e) >> throwIO e) + +-- | The function 'restrictToInterval a b' is the identify function +-- for numbers in the closed interval [a, b], it is the constant +-- function x \mapsto a on (-\infty, a) and the constant function x +-- \mapsto b on (b, \infty). +restrictToInterval :: Double -> Double -> Double -> Double +restrictToInterval lowerBound upperBound x + | x < lowerBound = lowerBound + | x > upperBound = upperBound + | otherwise = x + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Concurrent +import Control.Concurrent.Async.Refresh +import Control.Concurrent.STM +import Control.Exception +import Control.Monad.IO.Class +import Control.Monad.Logger +import Data.Function ((&)) +import Data.Text (Text) +import Data.Typeable +import Test.Framework (Test, defaultMain, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=)) + +main :: IO () +main = do + putStrLn "" + defaultMain tests + +tests :: [Test.Framework.Test] +tests = + [ testGroup "Test Suite" [ testCase "Simple one-time refreshing" oneTimeRefresh ] ] + +data Exn = NotFound deriving (Show, Typeable) + +instance Exception Exn + +callbackTVarStore :: MonadIO m => + TVar (Either SomeException a) + -> Either SomeException (RefreshResult a) + -> m () +callbackTVarStore store res = liftIO . atomically $ writeTVar store (refreshResult <$> res) + +oneTimeRefresh :: IO () +oneTimeRefresh = runStderrLoggingT $ do + store :: TVar (Either SomeException Text) <- liftIO $ newTVarIO (Left (toException NotFound)) + let conf = newAsyncRefreshConf (return (RefreshResult "foo" Nothing)) + & asyncRefreshConfSetLabel "Foo" + & asyncRefreshConfSetCallback (callbackTVarStore store) + asyncRefresh <- newAsyncRefresh conf + liftIO $ threadDelay (10 ^ 6 + 10 ^ 5) + storeContent <- liftIO $ atomically $ readTVar store + (Right storeContentRight) <- return storeContent + liftIO $ storeContentRight @?= "foo"