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