xrefcheck-0.2.2: tests/Test/Xrefcheck/TooManyRequestsSpec.hs
{- SPDX-FileCopyrightText: 2021 Serokell <https://serokell.io>
-
- SPDX-License-Identifier: MPL-2.0
-}
module Test.Xrefcheck.TooManyRequestsSpec where
import Universum
import Control.Concurrent (forkIO, killThread)
import Control.Exception qualified as E
import Data.CaseInsensitive qualified as CI
import Data.Map qualified as M
import Data.Time (addUTCTime, defaultTimeLocale, formatTime, getCurrentTime, rfc822DateFormat)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Fmt (indentF, pretty, unlinesF)
import Network.HTTP.Types (Status (..), ok200, serviceUnavailable503, tooManyRequests429)
import Network.HTTP.Types.Header (hRetryAfter)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertBool, testCase, (@?=))
import Time (sec, (-:-))
import Web.Firefly (ToResponse (toResponse), getMethod, route, run)
import Xrefcheck.Config
import Xrefcheck.Core
import Xrefcheck.Progress
import Xrefcheck.Util
import Xrefcheck.Verify
test_tooManyRequests :: TestTree
test_tooManyRequests = testGroup "429 response tests"
[ testCase "Returns 200 eventually" $ do
let prog = Progress{ pTotal = 1
, pCurrent = 1
, pErrorsUnfixable = 0
, pErrorsFixable = 0
, pTaskTimestamp = Nothing
}
checkLinkAndProgressWithServer (mock429 "1" ok200)
"http://127.0.0.1:5000/429" prog $ VerifyResult []
, testCase "Returns 503 eventually" $ do
let prog = Progress{ pTotal = 1
, pCurrent = 1
, pErrorsUnfixable = 1
, pErrorsFixable = 0
, pTaskTimestamp = Nothing
}
checkLinkAndProgressWithServer (mock429 "1" serviceUnavailable503)
"http://127.0.0.1:5000/429" prog $ VerifyResult
[ ExternalHttpResourceUnavailable $
Status { statusCode = 503, statusMessage = "Service Unavailable"}
]
, testCase "Successfully updates the new retry-after value (as seconds)" $ do
E.bracket (forkIO $ mock429 "2" ok200) killThread $ \_ -> do
now <- getPOSIXTime <&> posixTimeToTimeSecond
progressRef <- newIORef VerifyProgress
{ vrLocal = initProgress 0
, vrExternal = Progress
{ pTotal = 2
, pCurrent = 1
, pErrorsUnfixable = 0
, pErrorsFixable = 0
, pTaskTimestamp = Just (TaskTimestamp (sec 3) (now -:- sec 1.5))
}
}
_ <- verifyReferenceWithProgress
(Reference "" "http://127.0.0.1:5000/429" Nothing (Position Nothing))
progressRef
Progress{..} <- vrExternal <$> readIORef progressRef
let ttc = ttTimeToCompletion <$> pTaskTimestamp
flip assertBool (ttc == Just (sec 2)) $
"Expected time to completion be equal to " ++ show (Just $ sec 2) ++
", but instead it's " ++ show ttc
, testCase "Successfully updates the new retry-after value (as date)" $ do
utctime <- getCurrentTime
let
-- Set the @Retry-After@ response header value as (current datetime + 4 seconds)
retryAfter = formatTime defaultTimeLocale rfc822DateFormat (addUTCTime 4 utctime)
now = utcTimeToTimeSecond utctime
E.bracket (forkIO $ mock429 (fromString retryAfter) ok200) killThread $ \_ -> do
progressRef <- newIORef VerifyProgress
{ vrLocal = initProgress 0
, vrExternal = Progress
{ pTotal = 2
, pCurrent = 1
, pErrorsUnfixable = 0
, pErrorsFixable = 0
, pTaskTimestamp = Just (TaskTimestamp (sec 2) (now -:- sec 1.5))
}
}
_ <- verifyReferenceWithProgress
(Reference "" "http://127.0.0.1:5000/429" Nothing (Position Nothing))
progressRef
Progress{..} <- vrExternal <$> readIORef progressRef
let ttc = fromMaybe (sec 0) $ ttTimeToCompletion <$> pTaskTimestamp
flip assertBool (sec 3 <= ttc && ttc <= sec 4) $
"Expected time to completion be within range (seconds): 3 <= x <= 4" ++
", but instead it's " ++ show ttc
, testCase "Sets the new retry-after to 0 seconds if\
\ its value is a date && has already passed" $ do
utctime <- getCurrentTime
let
-- Set the @Retry-After@ response header value as (current datetime - 4 seconds)
retryAfter = formatTime defaultTimeLocale rfc822DateFormat (addUTCTime (-4) utctime)
now = utcTimeToTimeSecond utctime
E.bracket (forkIO $ mock429 (fromString retryAfter) ok200) killThread $ \_ -> do
progressRef <- newIORef VerifyProgress
{ vrLocal = initProgress 0
, vrExternal = Progress
{ pTotal = 2
, pCurrent = 1
, pErrorsUnfixable = 0
, pErrorsFixable = 0
, pTaskTimestamp = Just (TaskTimestamp (sec 1) (now -:- sec 1.5))
}
}
_ <- verifyReferenceWithProgress
(Reference "" "http://127.0.0.1:5000/429" Nothing (Position Nothing))
progressRef
Progress{..} <- vrExternal <$> readIORef progressRef
let ttc = ttTimeToCompletion <$> pTaskTimestamp
flip assertBool (ttc == Just (sec 0)) $
"Expected time to completion be 0 seconds" ++
", but instead it's " ++ show ttc
, testCase "The GET request should not be attempted after catching a 429" $ do
let
mock429WithGlobalIORef :: IORef [(Text, Status)] -> IO ()
mock429WithGlobalIORef infoReverseAccumulatorRef = do
callCountRef <- newIORef @_ @Int 0
run 5000 $ do
route "/429grandfinale" $ do
m <- getMethod
callCount <- atomicModifyIORef' callCountRef $ \cc -> (cc + 1, cc)
atomicModifyIORef' infoReverseAccumulatorRef $ \lst ->
( ( m
, if | m == "GET" -> ok200
| callCount == 0 -> tooManyRequests429
| otherwise -> serviceUnavailable503
) : lst
, ()
)
pure $ if
| m == "GET" -> toResponse ("" :: Text, ok200)
| callCount == 0 -> toResponse
( "" :: Text
, tooManyRequests429
, M.fromList [(CI.map (decodeUtf8 @Text) hRetryAfter, ["1" :: Text])]
)
| otherwise -> toResponse ("" :: Text, serviceUnavailable503)
infoReverseAccumulatorRef <- newIORef []
E.bracket (forkIO $ mock429WithGlobalIORef infoReverseAccumulatorRef) killThread $ \_ -> do
_ <- verifyLink "http://127.0.0.1:5000/429grandfinale"
infoReverseAccumulator <- readIORef infoReverseAccumulatorRef
reverse infoReverseAccumulator @?=
[ ("HEAD", tooManyRequests429)
, ("HEAD", serviceUnavailable503)
, ("GET", ok200)
]
]
where
checkLinkAndProgressWithServer mock link progress vrExpectation =
E.bracket (forkIO mock) killThread $ \_ -> do
(result, progRes) <- verifyLink link
flip assertBool (result == vrExpectation) . pretty $ unlinesF
[ "Verification results differ: expected"
, indentF 2 (show vrExpectation)
, "but got"
, indentF 2 (show result)
]
flip assertBool (progRes `progEquiv` progress) . pretty $ unlinesF
[ "Expected the progress bar state to be"
, indentF 2 (show progress)
, "but got"
, indentF 2 (show progRes)
]
where
-- | Check whether the two @Progress@ values are equal up to similarity of their essential
-- components, ignoring the comparison of @pTaskTimestamp@s, which is done to prevent test
-- failures when comparing the resulting progress, gotten from running the link
-- verification algorithm, with the expected one, where @pTaskTimestamp@ is hardcoded
-- as @Nothing@.
progEquiv :: Eq a => Progress a -> Progress a -> Bool
progEquiv p1 p2 = and [ ((==) `on` pCurrent) p1 p2
, ((==) `on` pTotal) p1 p2
, ((==) `on` pErrorsUnfixable) p1 p2
, ((==) `on` pErrorsFixable) p1 p2
]
verifyLink :: Text -> IO (VerifyResult VerifyError, Progress Int)
verifyLink link = do
let reference = Reference "" link Nothing (Position Nothing)
progRef <- newIORef $ initVerifyProgress [reference]
result <- verifyReferenceWithProgress reference progRef
progress <- readIORef progRef
return (result, vrExternal progress)
verifyReferenceWithProgress :: Reference -> IORef VerifyProgress -> IO (VerifyResult VerifyError)
verifyReferenceWithProgress reference progRef = do
fmap wrlItem <$> verifyReference
((cVerification $ defConfig GitHub) { vcIgnoreRefs = [] }) FullMode
progRef (RepoInfo M.empty mempty) "." "" reference
-- | When called for the first time, returns with a 429 and `Retry-After: @retryAfter@`.
-- Subsequent calls will respond with @status@.
mock429 :: Text -> Status -> IO ()
mock429 retryAfter status = do
callCountRef <- newIORef @_ @Int 0
run 5000 $
route "/429" $ do
callCount <- atomicModifyIORef' callCountRef $ \cc -> (cc + 1, cc)
pure $
if callCount == 0
then toResponse
( "" :: Text
, tooManyRequests429
, M.fromList [(CI.map (decodeUtf8 @Text) hRetryAfter, [retryAfter])]
)
else toResponse ("" :: Text, status)