Merge pull request #127 from serokell/nalkuatov/#99-add-date-support-for-retry-after

[#99] Support `Retry-After` headers with dates

CHANGES.md

@@ -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)

src/Xrefcheck/Util.hs

@@ -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

src/Xrefcheck/Verify.hs

@@ -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

tests/Test/Xrefcheck/TooManyRequestsSpec.hs

@@ -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 ()