From b80f71c0440cb059bf5b0d0a4b3a48564f696791 Mon Sep 17 00:00:00 2001 From: kawaharashotaro Date: Tue, 4 May 2021 13:07:03 +0900 Subject: [PATCH] #69 switching from using unliftio --- .gitignore | 4 +- retry.cabal | 2 + src/Control/Retry.hs | 81 +++++++++++-------------------------- test/Tests/Control/Retry.hs | 45 ++++++++++----------- 4 files changed, 51 insertions(+), 81 deletions(-) diff --git a/.gitignore b/.gitignore index 2a1f524..4413000 100644 --- a/.gitignore +++ b/.gitignore @@ -7,4 +7,6 @@ cabal-dev *.swp TAGS .stack-work -stack.yaml.lock \ No newline at end of file +stack.yaml.lock +*.idea +*.iml \ No newline at end of file diff --git a/retry.cabal b/retry.cabal index ed77a55..654002c 100644 --- a/retry.cabal +++ b/retry.cabal @@ -41,6 +41,7 @@ library , ghc-prim , random >= 1 , transformers + , unliftio >=0.2.14 hs-source-dirs: src default-language: Haskell2010 @@ -71,6 +72,7 @@ test-suite test , stm , ghc-prim , mtl + , unliftio >=0.2.14 default-language: Haskell2010 if flag(lib-Werror) diff --git a/src/Control/Retry.hs b/src/Control/Retry.hs index 8a71baf..d0c855e 100644 --- a/src/Control/Retry.hs +++ b/src/Control/Retry.hs @@ -81,14 +81,11 @@ module Control.Retry ------------------------------------------------------------------------------- import Control.Applicative import Control.Concurrent -#if MIN_VERSION_base(4, 7, 0) -import Control.Exception (AsyncException, SomeAsyncException) -#else + import Control.Exception (AsyncException) -#endif import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class +import Control.Monad.Catch (throwM, MonadThrow) +import UnliftIO (MonadUnliftIO, MonadIO, SomeException, SomeAsyncException, Handler(..), Exception, liftIO, mask, try, fromException) import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Control.Monad.Trans.State @@ -98,11 +95,7 @@ import GHC.Generics import GHC.Prim import GHC.Types (Int(I#)) import System.Random -# if MIN_VERSION_base(4, 9, 0) import Data.Semigroup -# else -import Data.Monoid -# endif import Prelude ------------------------------------------------------------------------------- @@ -160,7 +153,7 @@ retryPolicyDefault = constantDelay 50000 <> limitRetries 5 -- Base 4.9.0 adds a Data.Semigroup module. This has fewer -- dependencies than the semigroups package, so we're using base's -- only if its available. -# if MIN_VERSION_base(4, 9, 0) + instance Monad m => Semigroup (RetryPolicyM m) where (RetryPolicyM a) <> (RetryPolicyM b) = RetryPolicyM $ \ n -> runMaybeT $ do a' <- MaybeT $ a n @@ -171,14 +164,6 @@ instance Monad m => Semigroup (RetryPolicyM m) where instance Monad m => Monoid (RetryPolicyM m) where mempty = retryPolicy $ const (Just 0) mappend = (<>) -# else -instance Monad m => Monoid (RetryPolicyM m) where - mempty = retryPolicy $ const (Just 0) - (RetryPolicyM a) `mappend` (RetryPolicyM b) = RetryPolicyM $ \ n -> runMaybeT $ do - a' <- MaybeT $ a n - b' <- MaybeT $ b n - return $! max a' b' -#endif ------------------------------------------------------------------------------- @@ -525,11 +510,7 @@ retryingDynamic policy chk f = go defaultRetryStatus -- Running action -- *** Exception: this is an error recoverAll -#if MIN_VERSION_exceptions(0, 6, 0) - :: (MonadIO m, MonadMask m) -#else - :: (MonadIO m, MonadCatch m) -#endif + :: (MonadUnliftIO m, MonadThrow m) => RetryPolicyM m -> (RetryStatus -> m a) -> m a @@ -551,12 +532,12 @@ skipAsyncExceptions skipAsyncExceptions = handlers where asyncH _ = Handler $ \ (_ :: AsyncException) -> return False -#if MIN_VERSION_base(4, 7, 0) + someAsyncH _ = Handler $ \(_ :: SomeAsyncException) -> return False handlers = [asyncH, someAsyncH] -#else - handlers = [asyncH] -#endif + + + ------------------------------------------------------------------------------- @@ -569,14 +550,10 @@ skipAsyncExceptions = handlers -- just plan on catching 'SomeException', you may as well ues -- 'recoverAll' recovering -#if MIN_VERSION_exceptions(0, 6, 0) - :: (MonadIO m, MonadMask m) -#else - :: (MonadIO m, MonadCatch m) -#endif + :: (MonadUnliftIO m, MonadThrow m) => RetryPolicyM m -- ^ Just use 'retryPolicyDefault' for default settings - -> [(RetryStatus -> Handler m Bool)] + -> [RetryStatus -> Handler m Bool] -- ^ Should a given exception be retried? Action will be -- retried if this returns True *and* the policy allows it. -- This action will be consulted first even if the policy @@ -584,22 +561,18 @@ recovering -> (RetryStatus -> m a) -- ^ Action to perform -> m a -recovering policy hs f = - recoveringDynamic policy hs' f +recovering policy hs = recoveringDynamic policy hs' where - hs' = map (fmap toRetryAction .) hs + hs' = map (fmap' toRetryAction .) hs + fmap' f (Handler h) = Handler (liftM f . h) -- | The difference between this and 'recovering' is the same as -- the difference between 'retryingDynamic' and 'retrying'. recoveringDynamic -#if MIN_VERSION_exceptions(0, 6, 0) - :: (MonadIO m, MonadMask m) -#else - :: (MonadIO m, MonadCatch m) -#endif + :: (MonadUnliftIO m, MonadThrow m) => RetryPolicyM m -- ^ Just use 'retryPolicyDefault' for default settings - -> [(RetryStatus -> Handler m RetryAction)] + -> [RetryStatus -> Handler m RetryAction] -- ^ Should a given exception be retried? Action will be -- retried if this returns either 'ConsultPolicy' or -- 'ConsultPolicyOverrideDelay' *and* the policy allows it. @@ -642,11 +615,7 @@ recoveringDynamic policy hs f = mask $ \restore -> go restore defaultRetryStatus -- and failure. Useful for implementing retry logic in distributed -- queues and similar external-interfacing systems. stepping -#if MIN_VERSION_exceptions(0, 6, 0) - :: (MonadIO m, MonadMask m) -#else - :: (MonadIO m, MonadCatch m) -#endif + :: (MonadUnliftIO m, MonadThrow m) => RetryPolicyM m -- ^ Just use 'retryPolicyDefault' for default settings -> [(RetryStatus -> Handler m Bool)] @@ -671,15 +640,13 @@ stepping policy hs schedule f s = do recover e ((($ s) -> Handler h) : hs') | Just e' <- fromException e = do chk <- h e' - case chk of - True -> do - res <- applyPolicy policy s - case res of - Just rs -> do - schedule $! rs - return Nothing - Nothing -> throwM e' - False -> throwM e' + if chk then (do + res <- applyPolicy policy s + case res of + Just rs -> do + schedule $! rs + return Nothing + Nothing -> throwM e') else throwM e' | otherwise = recover e hs' diff --git a/test/Tests/Control/Retry.hs b/test/Tests/Control/Retry.hs index 6dd2e77..40d52e5 100644 --- a/test/Tests/Control/Retry.hs +++ b/test/Tests/Control/Retry.hs @@ -7,16 +7,13 @@ module Tests.Control.Retry ------------------------------------------------------------------------------- import Control.Applicative -import Control.Concurrent -import Control.Concurrent.STM as STM import qualified Control.Exception as EX -import Control.Monad.Catch +import Control.Monad.Catch (throwM) import Control.Monad.Identity import Control.Monad.IO.Class import Control.Monad.Writer.Strict import Data.Either -import Data.IORef -import Data.List +import Data.List (sort, group) import Data.Maybe import Data.Time.Clock import Data.Time.LocalTime () @@ -25,6 +22,8 @@ import Hedgehog as HH import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import System.IO.Error +import UnliftIO hiding (timeout) +import UnliftIO.Concurrent import Test.Tasty import Test.Tasty.Hedgehog import Test.Tasty.HUnit (assertBool, testCase, (@?=)) @@ -52,15 +51,15 @@ recoveringTests :: TestTree recoveringTests = testGroup "recovering" [ testProperty "recovering test without quadratic retry delay" $ property $ do startTime <- liftIO getCurrentTime - timeout <- forAll (Gen.int (Range.linear 0 15)) + timeout' <- forAll (Gen.int (Range.linear 0 15)) retries <- forAll (Gen.int (Range.linear 0 50)) res <- liftIO $ try $ recovering - (constantDelay timeout <> limitRetries retries) + (constantDelay timeout' <> limitRetries retries) testHandlers (const $ throwM (userError "booo")) endTime <- liftIO getCurrentTime HH.assert (isLeftAnd isUserError res) - let ms' = (fromInteger . toInteger $ (timeout * retries)) / 1000000.0 + let ms' = (fromInteger . toInteger $ (timeout' * retries)) / 1000000.0 HH.assert (diffUTCTime endTime startTime >= ms') , testGroup "exception hierarchy semantics" [ testCase "does not catch async exceptions" $ do @@ -71,7 +70,7 @@ recoveringTests = testGroup "recovering" tid <- forkIO $ recoverAll (limitRetries 2) (const work) `finally` putMVar done () - atomically (STM.check . (== 1) =<< readTVar counter) + atomically (checkSTM . (== 1) =<< readTVar counter) EX.throwTo tid EX.UserInterrupt takeMVar done @@ -182,7 +181,7 @@ monoidTests = testGroup "Policy is a monoid" delayC <- forAll genDelay let applyPolicy' f = liftIO $ getRetryPolicyM (f (retryPolicy (const delayA)) (retryPolicy (const delayB)) (retryPolicy (const delayC))) retryStatus res <- liftIO (liftA2 (==) (applyPolicy' left) (applyPolicy' right)) - assert res + HH.assert res ------------------------------------------------------------------------------- @@ -322,17 +321,15 @@ overridingDelayTests = testGroup "overriding delay" testOverride retryingDynamic (\delays rs _ -> return $ ConsultPolicyOverrideDelay (delays !! rsIterNumber rs)) - (\_ _ -> liftIO getCurrentTime >>= \time -> tell [time]) - , testProperty "recoveringDynamic" $ - testOverride - recoveringDynamic - (\delays -> [\rs -> Handler (\(_::SomeException) -> return $ ConsultPolicyOverrideDelay (delays !! rsIterNumber rs))]) - (\delays rs -> do - liftIO getCurrentTime >>= \time -> tell [time] - if rsIterNumber rs < length delays - then throwM (userError "booo") - else return () - ) + (\_ ref _ -> liftIO getCurrentTime >>= \time -> modifyIORef' ref (++[time])) + , testProperty "recoveringDynamic" $ + testOverride + recoveringDynamic + (\delays -> [\rs -> Handler (\(_::SomeException) -> return $ ConsultPolicyOverrideDelay (delays !! rsIterNumber rs))]) + (\delays ref rs -> do + liftIO getCurrentTime >>= \time -> modifyIORef' ref (++[time]) + when (rsIterNumber rs < length delays) $ throwM (userError "booo") + ) ] ] where @@ -344,13 +341,15 @@ overridingDelayTests = testGroup "overriding delay" toNominal = realToFrac -- Generic test case used to test both "retryingDynamic" and "recoveringDynamic" testOverride retryer handler action = property $ do + ref <- newIORef [] retryPolicy' <- forAll $ genPolicyNoLimit (Range.linear 1 1000000) delays <- forAll $ Gen.list (Range.linear 1 10) (Gen.int (Range.linear 10 1000)) - (_, measuredTimestamps) <- liftIO $ runWriterT $ retryer + _ <- liftIO $ retryer -- Stop retrying when we run out of delays (retryPolicy' <> limitRetries (length delays)) (handler delays) - (action delays) + (action delays ref) + measuredTimestamps <- readIORef ref let expectedDelays = map microsToNominalDiffTime delays forM_ (zip (diffTimes measuredTimestamps) expectedDelays) $ \(actual, expected) -> diff actual (>=) expected