diff --git a/src/Xrefcheck/Verify.hs b/src/Xrefcheck/Verify.hs index 15f1ca91..1117b23c 100644 --- a/src/Xrefcheck/Verify.hs +++ b/src/Xrefcheck/Verify.hs @@ -44,7 +44,7 @@ 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 (..), fmt, maybeF, nameF) +import Fmt (Buildable (..), Builder, fmt, maybeF, nameF) import GHC.Exts qualified as Exts import GHC.Read (Read (readPrec)) import Network.FTP.Client @@ -136,9 +136,9 @@ data VerifyError | ExternalFtpException FTPException | FtpEntryDoesNotExist FilePath | ExternalResourceSomeError Text - | RedirectChainCycle Text [Text] - | RedirectChainBroken Text [Text] - | RedirectRuleError (Maybe RedirectRuleOn) Text [Text] (Maybe Text) + | RedirectChainCycle (NonEmpty Text) + | RedirectChainBroken (NonEmpty Text) + | RedirectRuleError (Maybe RedirectRuleOn) (NonEmpty Text) (Maybe Text) deriving stock (Show, Eq) data ResponseResult @@ -246,38 +246,52 @@ instance Given ColorMode => Buildable VerifyError where #{err} |] - RedirectChainCycle _ _ -> + RedirectChainCycle chain -> [int|| Cycle found in the following redirect chain: - TODO print chain + #{interpolateIndentF 2 $ buildRedirectChain chain ["^-- here"]} |] - RedirectChainBroken _ _ -> + RedirectChainBroken chain -> [int|| Missin location header in the following redirect chain: - TODO print chain + #{interpolateIndentF 2 $ buildRedirectChain chain ["^-- no location header"]} |] - RedirectRuleError mOn link _ mLocation -> + RedirectRuleError mOn chain mLocation -> [int|| - #{redirect mOn} found - from: #{link} - #{to mLocation} - TODO optional to and print chain + #{redirect} found: + #{interpolateIndentF 2 $ buildRedirectChain chain attached} |] where - to :: Maybe Text -> Text - to = \case - Nothing -> "" - Just location -> "to: " <> location + attached :: [Text] + attached = case mLocation of + Nothing -> ["^-- redirects to unknown location"] + Just loc ->["^-- redirects to", loc] - redirect :: Maybe RedirectRuleOn -> Text - redirect = \case + redirect :: Text + redirect = case mOn of Nothing -> "Redirect" Just RROPermanent -> "Permanent redirect" Just RROTemporary -> "Temporary redirect" Just (RROCode code) -> show code <> "redirect" +buildRedirectChain :: NonEmpty Text -> [Text] -> Builder +buildRedirectChain (l :| ls) attached + = build chainText <> build attachedText + where + link (True, c) = "-| " <> c + link (False, c) = "-> " <> c + + chainText = mconcat + $ intersperse "\n" + $ fmap link + $ zip (True : repeat False) + $ reverse (l : ls) + + attachedText = mconcat + $ fmap ("\n " <>) attached + reportVerifyErrs :: Given ColorMode => NonEmpty (WithReferenceLoc VerifyError) -> IO () reportVerifyErrs errs = fmt @@ -288,7 +302,6 @@ reportVerifyErrs errs = fmt Invalid references dumped, #{length errs} in total. |] - data RetryAfter = Date UTCTime | Seconds (Time Second) deriving stock (Show, Eq) @@ -693,7 +706,7 @@ checkExternalResource :: [Text] -> Config -> Text -> IO (VerifyResult VerifyErro checkExternalResource followed config@Config{..} link | isIgnored = return mempty | otherwise = fmap toVerifyRes $ runExceptT $ do - when (link `elem` followed) $ throwError $ RedirectChainCycle link followed + when (link `elem` followed) $ throwError $ RedirectChainCycle $ (link :| followed) uri <- parseUri link case toString <$> uriScheme uri of Just "http" -> checkHttp uri @@ -770,10 +783,10 @@ checkExternalResource followed config@Config{..} link | Just RedirectRule{..} <- redirectRule link code ncExternalRefRedirects -> case rrOutcome of RROValid -> Right RRDone - RROInvalid -> Left $ RedirectRuleError rrOn link followed redirectLocation + RROInvalid -> Left $ RedirectRuleError rrOn (link :| followed) redirectLocation RROFollow -> case redirectLocation of - Nothing -> Left $ RedirectChainBroken link followed + Nothing -> Left $ RedirectChainBroken (link :| followed) Just nextLink -> Right $ RRFollow nextLink | isAllowedErrorCode code -> Right RRDone | otherwise -> case statusCode (responseStatus resp) of diff --git a/tests/Test/Xrefcheck/RedirectChainSpec.hs b/tests/Test/Xrefcheck/RedirectChainSpec.hs index 5c7e86c3..6aba9907 100644 --- a/tests/Test/Xrefcheck/RedirectChainSpec.hs +++ b/tests/Test/Xrefcheck/RedirectChainSpec.hs @@ -28,14 +28,14 @@ test_redirectRequests = testGroup "Redirect chain tests" mockRedirect brokenStart progress - (VerifyResult [RedirectChainBroken brokenEnd brokenStack]) + (VerifyResult [RedirectChainBroken (brokenEnd :| brokenStack)]) , testCase "Cycle" $ checkLinkAndProgressWithServer config mockRedirect cycleStart progress - (VerifyResult [RedirectChainCycle cycleEnd cycleStack]) + (VerifyResult [RedirectChainCycle (cycleEnd :| cycleStack)]) ] where brokenStart :: Text diff --git a/tests/Test/Xrefcheck/RedirectRequestsSpec.hs b/tests/Test/Xrefcheck/RedirectRequestsSpec.hs index 680c10b5..bb4ac57e 100644 --- a/tests/Test/Xrefcheck/RedirectRequestsSpec.hs +++ b/tests/Test/Xrefcheck/RedirectRequestsSpec.hs @@ -44,7 +44,7 @@ test_redirectRequests = testGroup "Redirect response tests" redirectTests (show statusCode <> " fails by default") (mkStatus statusCode "Permanent redirect") - (Just . RedirectRuleError (Just RROPermanent) url []) + (Just . RedirectRuleError (Just RROPermanent) (url :| [])) redirectTests :: TestName -> Status -> (Maybe Text -> Maybe VerifyError) -> TestTree redirectTests name expectedStatus expectedError = diff --git a/tests/golden/check-autolinks/check-autolinks.bats b/tests/golden/check-autolinks/check-autolinks.bats index 4d44a888..d7c7cd14 100644 --- a/tests/golden/check-autolinks/check-autolinks.bats +++ b/tests/golden/check-autolinks/check-autolinks.bats @@ -35,10 +35,10 @@ assert_diff - <