mirror of
https://github.com/serokell/xrefcheck.git
synced 2024-09-11 13:37:36 +03:00
Merge pull request #127 from serokell/nalkuatov/#99-add-date-support-for-retry-after
[#99] Support `Retry-After` headers with dates
This commit is contained in:
commit
acb2394c9c
@ -6,6 +6,8 @@
|
||||
|
||||
Unreleased
|
||||
==========
|
||||
* [#127](https://github.com/serokell/xrefcheck/pull/127)
|
||||
+ Support `Retry-After` headers with dates.
|
||||
* [#117](https://github.com/serokell/xrefcheck/pull/117)
|
||||
+ Forbid verifying a single file using `--root` command line option.
|
||||
* [#115](https://github.com/serokell/xrefcheck/pull/115)
|
||||
|
@ -13,6 +13,7 @@ module Xrefcheck.Util
|
||||
, aesonConfigOption
|
||||
, normaliseWithNoTrailing
|
||||
, posixTimeToTimeSecond
|
||||
, utcTimeToTimeSecond
|
||||
) where
|
||||
|
||||
import Universum
|
||||
@ -22,8 +23,9 @@ import Data.Aeson qualified as Aeson
|
||||
import Data.Aeson.Casing (aesonPrefix, camelCase)
|
||||
import Data.Fixed (Fixed (MkFixed), HasResolution (resolution))
|
||||
import Data.Ratio ((%))
|
||||
import Data.Time (UTCTime)
|
||||
import Data.Time.Clock (nominalDiffTimeToSeconds)
|
||||
import Data.Time.Clock.POSIX (POSIXTime)
|
||||
import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds)
|
||||
import Fmt (Builder, build, fmt, nameF)
|
||||
import System.Console.Pretty (Pretty (..), Style (Faint))
|
||||
import System.FilePath (dropTrailingPathSeparator, normalise)
|
||||
@ -59,3 +61,6 @@ posixTimeToTimeSecond :: POSIXTime -> Time Second
|
||||
posixTimeToTimeSecond posixTime =
|
||||
let picos@(MkFixed ps) = nominalDiffTimeToSeconds posixTime
|
||||
in sec . fromRational $ ps % resolution picos
|
||||
|
||||
utcTimeToTimeSecond :: UTCTime -> Time Second
|
||||
utcTimeToTimeSecond = posixTimeToTimeSecond . utcTimeToPOSIXSeconds
|
||||
|
@ -14,6 +14,7 @@ module Xrefcheck.Verify
|
||||
, verifyErrors
|
||||
, verifying
|
||||
|
||||
, RetryAfter (..)
|
||||
, WithReferenceLoc (..)
|
||||
|
||||
-- * Concurrent traversal with caching
|
||||
@ -37,10 +38,12 @@ import Data.List qualified as L
|
||||
import Data.Map qualified as M
|
||||
import Data.Text qualified as T
|
||||
import Data.Text.Metrics (damerauLevenshteinNorm)
|
||||
import Data.Time (UTCTime, defaultTimeLocale, formatTime, readPTime, rfc822DateFormat)
|
||||
import Data.Time.Clock.POSIX (getPOSIXTime)
|
||||
import Data.Traversable (for)
|
||||
import Fmt (Buildable (..), blockListF', listF, (+|), (|+))
|
||||
import Fmt (Buildable (..), blockListF', listF, maybeF, nameF, (+|), (|+))
|
||||
import GHC.Exts qualified as Exts
|
||||
import GHC.Read (Read (readPrec))
|
||||
import Network.FTP.Client
|
||||
(FTPException (..), FTPResponse (..), ResponseStatus (..), login, nlst, size, withFTP, withFTPS)
|
||||
import Network.HTTP.Client
|
||||
@ -54,9 +57,10 @@ import System.Console.Pretty (Style (..), style)
|
||||
import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist)
|
||||
import System.FilePath (takeDirectory, (</>), normalise)
|
||||
import System.FilePath.Glob qualified as Glob
|
||||
import Text.ParserCombinators.ReadPrec qualified as ReadPrec (lift)
|
||||
import Text.Regex.TDFA.Text (Regex, regexec)
|
||||
import Text.URI (Authority (..), URI (..), mkURI)
|
||||
import Time (RatioNat, Second, Time (..), ms, sec, threadDelay, timeout, (+:+))
|
||||
import Time (RatioNat, Second, Time (..), ms, sec, threadDelay, timeout, (+:+), (-:-))
|
||||
|
||||
import Data.Bits (toIntegralSized)
|
||||
import Xrefcheck.Config
|
||||
@ -118,7 +122,7 @@ data VerifyError
|
||||
| ExternalResourceInvalidUrl (Maybe Text)
|
||||
| ExternalResourceUnknownProtocol
|
||||
| ExternalHttpResourceUnavailable Status
|
||||
| ExternalHttpTooManyRequests (Time Second)
|
||||
| ExternalHttpTooManyRequests (Maybe RetryAfter)
|
||||
| ExternalFtpResourceUnavailable FTPResponse
|
||||
| ExternalFtpException FTPException
|
||||
| FtpEntryDoesNotExist FilePath
|
||||
@ -160,7 +164,7 @@ instance Buildable VerifyError where
|
||||
|
||||
ExternalHttpTooManyRequests retryAfter ->
|
||||
"⛂ Resource unavailable (429 Too Many Requests; retry after " +|
|
||||
show @Text retryAfter |+ ")\n"
|
||||
maybeF retryAfter |+ ")\n"
|
||||
|
||||
ExternalFtpResourceUnavailable response ->
|
||||
"⛂ Resource unavailable:\n" +| response |+ "\n"
|
||||
@ -179,6 +183,20 @@ instance Buildable VerifyError where
|
||||
[h] -> ",\n did you mean " +| h |+ "?\n"
|
||||
hs -> ", did you mean:\n" +| blockListF' " -" build hs
|
||||
|
||||
data RetryAfter = Date UTCTime | Seconds (Time Second)
|
||||
deriving stock (Show, Eq)
|
||||
|
||||
instance Read RetryAfter where
|
||||
readPrec = asum
|
||||
[ ReadPrec.lift $ Date <$> readPTime True defaultTimeLocale rfc822DateFormat
|
||||
, readPrec @Natural <&> Seconds . sec . fromIntegral @_ @RatioNat
|
||||
]
|
||||
|
||||
instance Buildable RetryAfter where
|
||||
build (Date d) = nameF "date" $
|
||||
fromString $ formatTime defaultTimeLocale rfc822DateFormat d
|
||||
build (Seconds s) = nameF "seconds" $ show s
|
||||
|
||||
-- | Determine whether the verification result contains a fixable error.
|
||||
isFixable :: VerifyError -> Bool
|
||||
isFixable (ExternalHttpTooManyRequests _) = True
|
||||
@ -300,15 +318,22 @@ verifyReference
|
||||
retryVerification numberOfRetries resIO = do
|
||||
res@(VerifyResult ves) <- resIO
|
||||
|
||||
now <- getPOSIXTime <&> posixTimeToTimeSecond
|
||||
|
||||
let toSeconds = \case
|
||||
Seconds s -> s
|
||||
-- Calculates the seconds left until @Retry-After@ date.
|
||||
-- Defaults to 0 if the date has already passed.
|
||||
Date date | utcTimeToTimeSecond date >= now -> utcTimeToTimeSecond date -:- now
|
||||
_ -> sec 0
|
||||
|
||||
let toRetry = any isFixable ves && numberOfRetries < vcMaxRetries
|
||||
currentRetryAfter = extractRetryAfterInfo res
|
||||
currentRetryAfter = fromMaybe vcDefaultRetryAfter $
|
||||
extractRetryAfterInfo res <&> toSeconds
|
||||
|
||||
let moveProgress = alterOverallProgress numberOfRetries
|
||||
. alterProgressErrors res numberOfRetries
|
||||
|
||||
posixTime' <- getPOSIXTime
|
||||
let posixTime = posixTimeToTimeSecond posixTime'
|
||||
|
||||
atomicModifyIORef' progressRef $ \VerifyProgress{..} ->
|
||||
( if isExternal $ locationType rLink
|
||||
then VerifyProgress{ vrExternal =
|
||||
@ -316,8 +341,8 @@ verifyReference
|
||||
in if toRetry
|
||||
then case pTaskTimestamp vrExternal of
|
||||
Just (TaskTimestamp ttc start)
|
||||
| currentRetryAfter +:+ posixTime <= ttc +:+ start -> vrExternalAdvanced
|
||||
_ -> setTaskTimestamp currentRetryAfter posixTime vrExternalAdvanced
|
||||
| currentRetryAfter +:+ now <= ttc +:+ start -> vrExternalAdvanced
|
||||
_ -> setTaskTimestamp currentRetryAfter now vrExternalAdvanced
|
||||
else vrExternalAdvanced, .. }
|
||||
else VerifyProgress{ vrLocal = moveProgress vrLocal, .. }
|
||||
, ()
|
||||
@ -363,10 +388,10 @@ verifyReference
|
||||
ok = verifyOk res
|
||||
fixable = any isFixable ves
|
||||
|
||||
extractRetryAfterInfo :: VerifyResult VerifyError -> Time Second
|
||||
extractRetryAfterInfo :: VerifyResult VerifyError -> Maybe RetryAfter
|
||||
extractRetryAfterInfo = \case
|
||||
VerifyResult [ExternalHttpTooManyRequests retryAfter] -> retryAfter
|
||||
_ -> vcDefaultRetryAfter
|
||||
_ -> Nothing
|
||||
|
||||
checkRef mAnchor referredFile = verifying $ do
|
||||
checkReferredFileExists referredFile
|
||||
@ -499,13 +524,8 @@ checkExternalResource VerifyConfig{..} link
|
||||
_ -> Left . ExternalHttpResourceUnavailable $ responseStatus resp
|
||||
other -> Left . ExternalResourceSomeError $ show other
|
||||
where
|
||||
retryAfterInfo :: Response a -> Time Second
|
||||
retryAfterInfo response =
|
||||
fromMaybe vcDefaultRetryAfter $ do
|
||||
retryAfterByteString <- L.lookup hRetryAfter $ responseHeaders response
|
||||
retryAfterString <- rightToMaybe $ decodeUtf8Strict @String retryAfterByteString
|
||||
retryAfter <- readMaybe @Natural retryAfterString
|
||||
pure . sec $ fromIntegral @Natural @RatioNat retryAfter
|
||||
retryAfterInfo :: Response a -> Maybe RetryAfter
|
||||
retryAfterInfo = readMaybe . decodeUtf8 <=< L.lookup hRetryAfter . responseHeaders
|
||||
|
||||
checkFtp :: URI -> Bool -> ExceptT VerifyError IO ()
|
||||
checkFtp uri secure = do
|
||||
|
@ -11,6 +11,7 @@ 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, formatTime, getCurrentTime, defaultTimeLocale, rfc822DateFormat)
|
||||
import Data.Time.Clock.POSIX (getPOSIXTime)
|
||||
import Fmt (indentF, pretty, unlinesF)
|
||||
import Network.HTTP.Types (Status (..), ok200, serviceUnavailable503, tooManyRequests429)
|
||||
@ -50,7 +51,7 @@ spec = do
|
||||
[ ExternalHttpResourceUnavailable $
|
||||
Status { statusCode = 503, statusMessage = "Service Unavailable"}
|
||||
]
|
||||
it "Successfully updates the new retry-after value" $ do
|
||||
it "Successfully updates the new retry-after value (as seconds)" $ do
|
||||
E.bracket (forkIO $ mock429 "2" ok200) killThread $ \_ -> do
|
||||
now <- getPOSIXTime <&> posixTimeToTimeSecond
|
||||
progressRef <- newIORef VerifyProgress
|
||||
@ -71,6 +72,56 @@ spec = do
|
||||
flip assertBool (ttc == Just (sec 2)) $
|
||||
"Expected time to completion be equal to " ++ show (Just $ sec 2) ++
|
||||
", but instead it's " ++ show ttc
|
||||
it "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
|
||||
it "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
|
||||
it "The GET request should not be attempted after catching a 429" $ do
|
||||
let
|
||||
mock429WithGlobalIORef :: IORef [(Text, Status)] -> IO ()
|
||||
|
Loading…
Reference in New Issue
Block a user