packages feed

async-refresh (empty) → 0.1.7

raw patch · 10 files changed

+499/−0 lines, 10 filesdep +HUnitdep +async-refreshdep +basesetup-changed

Dependencies added: HUnit, async-refresh, base, criterion, formatting, lens, lifted-async, monad-control, monad-logger, safe-exceptions, stm, test-framework, test-framework-hunit, text

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -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+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ async-refresh.cabal view
@@ -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
+ src/Control/Concurrent/Async/Refresh.hs view
@@ -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
+ src/Control/Concurrent/Async/Refresh/Lenses.hs view
@@ -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
+ src/Control/Concurrent/Async/Refresh/Prelude.hs view
@@ -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
+ src/Control/Concurrent/Async/Refresh/Types.hs view
@@ -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)
+ src/Control/Concurrent/Async/Refresh/Util.hs view
@@ -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+
+ test/Spec.hs view
@@ -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"