1{-# OPTIONS_GHC -fno-warn-orphans #-} 2{-# LANGUAGE DeriveDataTypeable #-} 3{-# LANGUAGE ScopedTypeVariables #-} 4module Tests.Control.Retry 5 ( tests 6 ) where 7 8------------------------------------------------------------------------------- 9import Control.Applicative 10import Control.Concurrent 11import Control.Concurrent.STM as STM 12import qualified Control.Exception as EX 13import Control.Monad.Catch 14import Control.Monad.Identity 15import Control.Monad.IO.Class 16import Control.Monad.Writer.Strict 17import Data.Either 18import Data.IORef 19import Data.List 20import Data.Maybe 21import Data.Time.Clock 22import Data.Time.LocalTime () 23import Data.Typeable 24import Hedgehog as HH 25import qualified Hedgehog.Gen as Gen 26import qualified Hedgehog.Range as Range 27import System.IO.Error 28import Test.Tasty 29import Test.Tasty.Hedgehog 30import Test.Tasty.HUnit (assertBool, testCase, (@?=)) 31------------------------------------------------------------------------------- 32import Control.Retry 33------------------------------------------------------------------------------- 34 35 36tests :: TestTree 37tests = testGroup "Control.Retry" 38 [ recoveringTests 39 , monoidTests 40 , retryStatusTests 41 , quadraticDelayTests 42 , policyTransformersTests 43 , maskingStateTests 44 , capDelayTests 45 , limitRetriesByCumulativeDelayTests 46 , overridingDelayTests 47 ] 48 49 50------------------------------------------------------------------------------- 51recoveringTests :: TestTree 52recoveringTests = testGroup "recovering" 53 [ testProperty "recovering test without quadratic retry delay" $ property $ do 54 startTime <- liftIO getCurrentTime 55 timeout <- forAll (Gen.int (Range.linear 0 15)) 56 retries <- forAll (Gen.int (Range.linear 0 50)) 57 res <- liftIO $ try $ recovering 58 (constantDelay timeout <> limitRetries retries) 59 testHandlers 60 (const $ throwM (userError "booo")) 61 endTime <- liftIO getCurrentTime 62 HH.assert (isLeftAnd isUserError res) 63 let ms' = (fromInteger . toInteger $ (timeout * retries)) / 1000000.0 64 HH.assert (diffUTCTime endTime startTime >= ms') 65 , testGroup "exception hierarchy semantics" 66 [ testCase "does not catch async exceptions" $ do 67 counter <- newTVarIO (0 :: Int) 68 done <- newEmptyMVar 69 let work = atomically (modifyTVar' counter succ) >> threadDelay 1000000 70 71 tid <- forkIO $ 72 recoverAll (limitRetries 2) (const work) `finally` putMVar done () 73 74 atomically (STM.check . (== 1) =<< readTVar counter) 75 EX.throwTo tid EX.UserInterrupt 76 77 takeMVar done 78 79 count <- atomically (readTVar counter) 80 count @?= 1 81 82 , testCase "recovers from custom exceptions" $ do 83 f <- mkFailN Custom1 2 84 res <- try $ recovering 85 (constantDelay 5000 <> limitRetries 3) 86 [const $ Handler $ \ Custom1 -> return shouldRetry] 87 f 88 (res :: Either Custom1 ()) @?= Right () 89 90 , testCase "fails beyond policy using custom exceptions" $ do 91 f <- mkFailN Custom1 3 92 res <- try $ recovering 93 (constantDelay 5000 <> limitRetries 2) 94 [const $ Handler $ \ Custom1 -> return shouldRetry] 95 f 96 (res :: Either Custom1 ()) @?= Left Custom1 97 98 , testCase "recoverAll won't catch exceptions which are not decendants of SomeException" $ do 99 f <- mkFailN Custom1 4 100 res <- try $ recoverAll 101 (constantDelay 5000 <> limitRetries 3) 102 f 103 (res :: Either Custom1 ()) @?= Left Custom1 104 105 , testCase "does not recover from unhandled exceptions" $ do 106 f <- mkFailN Custom2 2 107 res <- try $ recovering 108 (constantDelay 5000 <> limitRetries 5) 109 [const $ Handler $ \ Custom1 -> return shouldRetry] 110 f 111 (res :: Either Custom2 ()) @?= Left Custom2 112 113 114 , testCase "recovers in presence of multiple handlers" $ do 115 f <- mkFailN Custom2 2 116 res <- try $ recovering 117 (constantDelay 5000 <> limitRetries 5) 118 [ const $ Handler $ \ Custom1 -> return shouldRetry 119 , const $ Handler $ \ Custom2 -> return shouldRetry ] 120 f 121 (res :: Either Custom2 ()) @?= Right () 122 123 124 , testCase "general exceptions catch specific ones" $ do 125 f <- mkFailN Custom2 2 126 res <- try $ recovering 127 (constantDelay 5000 <> limitRetries 5) 128 [ const $ Handler $ \ (_::SomeException) -> return shouldRetry ] 129 f 130 (res :: Either Custom2 ()) @?= Right () 131 132 133 , testCase "(redundant) even general catchers don't go beyond policy" $ do 134 f <- mkFailN Custom2 3 135 res <- try $ recovering 136 (constantDelay 5000 <> limitRetries 2) 137 [ const $ Handler $ \ (_::SomeException) -> return shouldRetry ] 138 f 139 (res :: Either Custom2 ()) @?= Left Custom2 140 141 142 , testCase "rethrows in presence of failed exception casts" $ do 143 f <- mkFailN Custom2 3 144 final <- try $ do 145 res <- try $ recovering 146 (constantDelay 5000 <> limitRetries 2) 147 [ const $ Handler $ \ (_::SomeException) -> return shouldRetry ] 148 f 149 (res :: Either Custom1 ()) @?= Left Custom1 150 final @?= Left Custom2 151 ] 152 ] 153 154 155------------------------------------------------------------------------------- 156monoidTests :: TestTree 157monoidTests = testGroup "Policy is a monoid" 158 [ testProperty "left identity" $ property $ 159 propIdentity (\p -> mempty <> p) id 160 , testProperty "right identity" $ property $ 161 propIdentity (\p -> p <> mempty) id 162 , testProperty "associativity" $ property $ 163 propAssociativity (\x y z -> x <> (y <> z)) (\x y z -> (x <> y) <> z) 164 ] 165 where 166 propIdentity left right = do 167 retryStatus <- forAll genRetryStatus 168 fixedDelay <- forAll (Gen.maybe (Gen.int (Range.linear 0 maxBound))) 169 let calculateDelay _rs = fixedDelay 170 let applyPolicy' f = getRetryPolicyM (f $ retryPolicy calculateDelay) retryStatus 171 validRes = maybe True (>= 0) 172 l <- liftIO $ applyPolicy' left 173 r <- liftIO $ applyPolicy' right 174 if validRes r && validRes l 175 then l === r 176 else return () 177 propAssociativity left right = do 178 retryStatus <- forAll genRetryStatus 179 let genDelay = Gen.maybe (Gen.int (Range.linear 0 maxBound)) 180 delayA <- forAll genDelay 181 delayB <- forAll genDelay 182 delayC <- forAll genDelay 183 let applyPolicy' f = liftIO $ getRetryPolicyM (f (retryPolicy (const delayA)) (retryPolicy (const delayB)) (retryPolicy (const delayC))) retryStatus 184 res <- liftIO (liftA2 (==) (applyPolicy' left) (applyPolicy' right)) 185 assert res 186 187 188------------------------------------------------------------------------------- 189retryStatusTests :: TestTree 190retryStatusTests = testGroup "retry status" 191 [ testCase "passes the correct retry status each time" $ do 192 let policy = limitRetries 2 <> constantDelay 100 193 rses <- gatherStatuses policy 194 rsIterNumber <$> rses @?= [0, 1, 2] 195 rsCumulativeDelay <$> rses @?= [0, 100, 200] 196 rsPreviousDelay <$> rses @?= [Nothing, Just 100, Just 100] 197 ] 198 199 200------------------------------------------------------------------------------- 201policyTransformersTests :: TestTree 202policyTransformersTests = testGroup "policy transformers" 203 [ testProperty "always produces positive delay with positive constants (no rollover)" $ property $ do 204 delay <- forAll (Gen.int (Range.linear 0 maxBound)) 205 let res = runIdentity (simulatePolicy 1000 (exponentialBackoff delay)) 206 delays = catMaybes (snd <$> res) 207 mnDelay = if null delays 208 then Nothing 209 else Just (minimum delays) 210 case mnDelay of 211 Nothing -> return () 212 Just n -> do 213 footnote (show n ++ " is not >= 0") 214 HH.assert (n >= 0) 215 , testProperty "positive, nonzero exponential backoff is always incrementing" $ property $ do 216 delay <- forAll (Gen.int (Range.linear 1 maxBound)) 217 let res = runIdentity (simulatePolicy 1000 (limitRetriesByDelay maxBound (exponentialBackoff delay))) 218 delays = catMaybes (snd <$> res) 219 sort delays === delays 220 length (group delays) === length delays 221 ] 222 223 224------------------------------------------------------------------------------- 225maskingStateTests :: TestTree 226maskingStateTests = testGroup "masking state" 227 [ testCase "shouldn't change masking state in a recovered action" $ do 228 maskingState <- EX.getMaskingState 229 final <- try $ recovering retryPolicyDefault testHandlers $ const $ do 230 maskingState' <- EX.getMaskingState 231 maskingState' @?= maskingState 232 fail "Retrying..." 233 assertBool 234 ("Expected EX.IOException but didn't get one") 235 (isLeft (final :: Either EX.IOException ())) 236 237 , testCase "should mask asynchronous exceptions in exception handlers" $ do 238 let checkMaskingStateHandlers = 239 [ const $ Handler $ \(_ :: SomeException) -> do 240 maskingState <- EX.getMaskingState 241 maskingState @?= EX.MaskedInterruptible 242 return shouldRetry 243 ] 244 final <- try $ recovering retryPolicyDefault checkMaskingStateHandlers $ const $ fail "Retrying..." 245 assertBool 246 ("Expected EX.IOException but didn't get one") 247 (isLeft (final :: Either EX.IOException ())) 248 ] 249 250 251------------------------------------------------------------------------------- 252capDelayTests :: TestTree 253capDelayTests = testGroup "capDelay" 254 [ testProperty "respects limitRetries" $ property $ do 255 retries <- forAll (Gen.int (Range.linear 1 100)) 256 cap <- forAll (Gen.int (Range.linear 1 maxBound)) 257 let policy = capDelay cap (limitRetries retries) 258 let delays = runIdentity (simulatePolicy (retries + 1) policy) 259 let Just lastDelay = lookup (retries - 1) delays 260 let Just gaveUp = lookup retries delays 261 let noDelay = 0 262 lastDelay === Just noDelay 263 gaveUp === Nothing 264 , testProperty "does not allow any delays higher than the given delay" $ property $ do 265 cap <- forAll (Gen.int (Range.linear 1 maxBound)) 266 baseDelay <- forAll (Gen.int (Range.linear 1 100)) 267 basePolicy <- forAllWith (const "RetryPolicy") (genScalingPolicy baseDelay) 268 let policy = capDelay cap basePolicy 269 let delays = catMaybes (snd <$> runIdentity (simulatePolicy 100 policy)) 270 let baddies = filter (> cap) delays 271 baddies === [] 272 ] 273 274 275------------------------------------------------------------------------------- 276-- | Generates policies that increase on each iteration 277genScalingPolicy :: (Alternative m) => Int -> m (RetryPolicyM Identity) 278genScalingPolicy baseDelay = 279 (pure (exponentialBackoff baseDelay) <|> pure (fibonacciBackoff baseDelay)) 280 281 282------------------------------------------------------------------------------- 283limitRetriesByCumulativeDelayTests :: TestTree 284limitRetriesByCumulativeDelayTests = testGroup "limitRetriesByCumulativeDelay" 285 [ testProperty "never exceeds the given cumulative delay" $ property $ do 286 baseDelay <- forAll (Gen.int (Range.linear 1 100)) 287 basePolicy <- forAllWith (const "RetryPolicy") (genScalingPolicy baseDelay) 288 cumulativeDelayMax <- forAll (Gen.int (Range.linear 1 10000)) 289 let policy = limitRetriesByCumulativeDelay cumulativeDelayMax basePolicy 290 let delays = catMaybes (snd <$> runIdentity (simulatePolicy 100 policy)) 291 footnoteShow delays 292 let actualCumulativeDelay = sum delays 293 footnote (show actualCumulativeDelay <> " <= " <> show cumulativeDelayMax) 294 HH.assert (actualCumulativeDelay <= cumulativeDelayMax) 295 296 ] 297 298------------------------------------------------------------------------------- 299quadraticDelayTests :: TestTree 300quadraticDelayTests = testGroup "quadratic delay" 301 [ testProperty "recovering test with quadratic retry delay" $ property $ do 302 startTime <- liftIO getCurrentTime 303 timeout <- forAll (Gen.int (Range.linear 0 15)) 304 retries <- forAll (Gen.int (Range.linear 0 8)) 305 res <- liftIO $ try $ recovering 306 (exponentialBackoff timeout <> limitRetries retries) 307 [const $ Handler (\(_::SomeException) -> return True)] 308 (const $ throwM (userError "booo")) 309 endTime <- liftIO getCurrentTime 310 HH.assert (isLeftAnd isUserError res) 311 let tmo = if retries > 0 then timeout * 2 ^ (retries - 1) else 0 312 let ms' = ((fromInteger . toInteger $ tmo) / 1000000.0) 313 HH.assert (diffUTCTime endTime startTime >= ms') 314 ] 315 316 317------------------------------------------------------------------------------- 318overridingDelayTests :: TestTree 319overridingDelayTests = testGroup "overriding delay" 320 [ testGroup "actual delays don't exceed specified delays" 321 [ testProperty "retryingDynamic" $ 322 testOverride 323 retryingDynamic 324 (\delays rs _ -> return $ ConsultPolicyOverrideDelay (delays !! rsIterNumber rs)) 325 (\_ _ -> liftIO getCurrentTime >>= \time -> tell [time]) 326 , testProperty "recoveringDynamic" $ 327 testOverride 328 recoveringDynamic 329 (\delays -> [\rs -> Handler (\(_::SomeException) -> return $ ConsultPolicyOverrideDelay (delays !! rsIterNumber rs))]) 330 (\delays rs -> do 331 liftIO getCurrentTime >>= \time -> tell [time] 332 if rsIterNumber rs < length delays 333 then throwM (userError "booo") 334 else return () 335 ) 336 ] 337 ] 338 where 339 -- Transform a list of timestamps into a list of differences 340 -- between adjacent timestamps. 341 diffTimes = compareAdjacent (flip diffUTCTime) 342 microsToNominalDiffTime = toNominal . picosecondsToDiffTime . (* 1000000) . fromIntegral 343 toNominal :: DiffTime -> NominalDiffTime 344 toNominal = realToFrac 345 -- Generic test case used to test both "retryingDynamic" and "recoveringDynamic" 346 testOverride retryer handler action = property $ do 347 retryPolicy' <- forAll $ genPolicyNoLimit (Range.linear 1 1000000) 348 delays <- forAll $ Gen.list (Range.linear 1 10) (Gen.int (Range.linear 10 1000)) 349 (_, measuredTimestamps) <- liftIO $ runWriterT $ retryer 350 -- Stop retrying when we run out of delays 351 (retryPolicy' <> limitRetries (length delays)) 352 (handler delays) 353 (action delays) 354 let expectedDelays = map microsToNominalDiffTime delays 355 forM_ (zip (diffTimes measuredTimestamps) expectedDelays) $ 356 \(actual, expected) -> diff actual (>=) expected 357 358------------------------------------------------------------------------------- 359isLeftAnd :: (a -> Bool) -> Either a b -> Bool 360isLeftAnd f ei = case ei of 361 Left v -> f v 362 _ -> False 363 364testHandlers :: [a -> Handler IO Bool] 365testHandlers = [const $ Handler (\(_::SomeException) -> return shouldRetry)] 366 367-- | Apply a function to adjacent list items. 368-- 369-- Ie.: 370-- > compareAdjacent f [a0, a1, a2, a3, ..., a(n-2), a(n-1), an] = 371-- > [f a0 a1, f a1 a2, f a2 a3, ..., f a(n-2) a(n-1), f a(n-1) an] 372-- 373-- Not defined for lists of length < 2. 374compareAdjacent :: (a -> a -> b) -> [a] -> [b] 375compareAdjacent f lst = 376 reverse . snd $ foldl 377 (\(a1, accum) a2 -> (a2, f a1 a2 : accum)) 378 (head lst, []) 379 (tail lst) 380 381data Custom1 = Custom1 deriving (Eq,Show,Read,Ord,Typeable) 382data Custom2 = Custom2 deriving (Eq,Show,Read,Ord,Typeable) 383 384 385instance Exception Custom1 386instance Exception Custom2 387 388 389------------------------------------------------------------------------------- 390genRetryStatus :: MonadGen m => m RetryStatus 391genRetryStatus = do 392 n <- Gen.int (Range.linear 0 maxBound) 393 d <- Gen.int (Range.linear 0 maxBound) 394 l <- Gen.maybe (Gen.int (Range.linear 0 d)) 395 return $ defaultRetryStatus { rsIterNumber = n 396 , rsCumulativeDelay = d 397 , rsPreviousDelay = l} 398 399 400------------------------------------------------------------------------------- 401-- | Generate an arbitrary 'RetryPolicy' without any limits applied. 402genPolicyNoLimit 403 :: (MonadGen mg, MonadIO mr) 404 => Range Int 405 -> mg (RetryPolicyM mr) 406genPolicyNoLimit durationRange = 407 Gen.choice 408 [ genConstantDelay 409 , genExponentialBackoff 410 , genFullJitterBackoff 411 , genFibonacciBackoff 412 ] 413 where 414 genDuration = Gen.int durationRange 415 -- Retry policies 416 genConstantDelay = fmap constantDelay genDuration 417 genExponentialBackoff = fmap exponentialBackoff genDuration 418 genFullJitterBackoff = fmap fullJitterBackoff genDuration 419 genFibonacciBackoff = fmap fibonacciBackoff genDuration 420 421-- Needed to generate a 'RetryPolicyM' using 'forAll' 422instance Show (RetryPolicyM m) where 423 show = const "RetryPolicyM" 424 425 426------------------------------------------------------------------------------- 427-- | Create an action that will fail exactly N times with the given 428-- exception and will then return () in any subsequent calls. 429mkFailN :: (Exception e) => e -> Int -> IO (s -> IO ()) 430mkFailN e n = do 431 r <- newIORef 0 432 return $ const $ do 433 old <- atomicModifyIORef' r $ \ old -> (old+1, old) 434 case old >= n of 435 True -> return () 436 False -> throwM e 437 438 439------------------------------------------------------------------------------- 440gatherStatuses 441 :: MonadIO m 442 => RetryPolicyM (WriterT [RetryStatus] m) 443 -> m [RetryStatus] 444gatherStatuses policy = execWriterT $ 445 retrying policy (\_ _ -> return shouldRetry) 446 (\rs -> tell [rs]) 447 448 449------------------------------------------------------------------------------- 450-- | Just makes things a bit easier to follow instead of a magic value 451-- of @return True@ 452shouldRetry :: Bool 453shouldRetry = True 454