[#25] Redirect chain verify errors output

Proposal of showing redirect chains in the verify errors output.

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

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

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 =

tests/golden/check-autolinks/check-autolinks.bats

@@ -35,10 +35,10 @@ assert_diff - <<EOF
        - link: http://www.commonmark.org
        - anchor: -
 
-     Permanent redirect found. Perhaps you want to replace the link:
-       http://www.commonmark.org
-     by:
-       https://commonmark.org/
+     Permanent redirect found:
+       -| http://www.commonmark.org
+          ^-- redirects to
+          https://commonmark.org/
 
 Invalid references dumped, 1 in total.
 EOF