[#25] Replace default behavior by rules

Replace the default behavior code by rules.

src/Xrefcheck/Config.hs

@@ -99,7 +99,7 @@ data RedirectRuleOutcome
       -- ^ Consider it as invalid
     | RROFollow
       -- ^ Try again by following the redirect
-    deriving stock (Generic)
+    deriving stock (Show, Eq)
 
 -- | Rule selector depending on the response HTTP code.
 data RedirectRuleOn
@@ -109,13 +109,13 @@ data RedirectRuleOn
       -- ^ Any HTTP code considered as permanent according to 'isPermanentRedirectCode'
     | RROTemporary
       -- ^ Any HTTP code considered as permanent according to 'isTemporaryRedirectCode'
-    deriving stock (Generic)
+    deriving stock (Show, Eq)
 
 -- | Redirect rule to apply to a link when it has been responded with a given
 -- HTTP code.
-redirectRule :: Text -> Int -> RedirectConfig -> Maybe RedirectRuleOutcome
+redirectRule :: Text -> Int -> RedirectConfig -> Maybe RedirectRule
 redirectRule link code rules =
-  rrOutcome <$> find (matchRule link code) rules
+  find (matchRule link code) rules
 
 -- | Check if a 'RedirectRule' matches a given link and HTTP code.
 matchRule :: Text -> Int -> RedirectRule -> Bool

src/Xrefcheck/Config/Default.hs

@@ -57,8 +57,14 @@ networking:
   maxRetries: 3
 
   # Rules to override the redirect behavior for external references that
-  # match. An example rule is {to: *, outcome: valid, on: permanent}
-  externalRefRedirects: []
+  # match.
+  externalRefRedirects:
+    - to: .*
+      on: permanent
+      outcome: invalid
+    - to: .*
+      on: temporary
+      outcome: valid
 
 # Parameters of scanners for various file types.
 scanners:

src/Xrefcheck/Verify.hs

@@ -136,10 +136,9 @@ data VerifyError
   | ExternalFtpException FTPException
   | FtpEntryDoesNotExist FilePath
   | ExternalResourceSomeError Text
-  | PermanentRedirectError Text (Maybe Text)
-  | RedirectCycle [Text]
-  | RedirectNoLocation [Text]
-  | RedirectRuleError [Text]
+  | RedirectChainCycle Text [Text]
+  | RedirectChainBroken Text [Text]
+  | RedirectRuleError (Maybe RedirectRuleOn) Text [Text] (Maybe Text)
   deriving stock (Show, Eq)
 
 data ResponseResult
@@ -247,37 +246,37 @@ instance Given ColorMode => Buildable VerifyError where
       #{err}
       |]
 
-    PermanentRedirectError url Nothing ->
-      [int||
-      Permanent redirect found:
-      #{url}
-      |]
-
-    PermanentRedirectError url (Just redirectedUrl) ->
-      [int||
-      Permanent redirect found. Perhaps you want to replace the link:
-        #{url}
-      by:
-        #{redirectedUrl}
-      |]
-
-    RedirectCycle _ ->
+    RedirectChainCycle _ _ ->
       [int||
       Cycle found in the following redirect chain:
       TODO print chain
       |]
 
-    RedirectNoLocation _ ->
+    RedirectChainBroken _ _ ->
       [int||
       Missin location header in the following redirect chain:
       TODO print chain
       |]
 
-    RedirectRuleError _ ->
+    RedirectRuleError mOn link _ mLocation ->
       [int||
-      Redirect rule invalidates the following redirect chain:
-      TODO print chain
+      #{redirect mOn} found
+        from: #{link}
+        #{to mLocation}
+        TODO optional to and print chain
       |]
+      where
+        to :: Maybe Text -> Text
+        to = \case
+          Nothing -> ""
+          Just location -> "to:   " <> location
+
+        redirect :: Maybe RedirectRuleOn -> Text
+        redirect = \case
+          Nothing -> "Redirect"
+          Just RROPermanent -> "Permanent redirect"
+          Just RROTemporary -> "Temporary redirect"
+          Just (RROCode code) -> show code <> "redirect"
 
 reportVerifyErrs
   :: Given ColorMode => NonEmpty (WithReferenceLoc VerifyError) -> IO ()
@@ -694,7 +693,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 $ RedirectCycle (link : followed)
+      when (link `elem` followed) $ throwError $ RedirectChainCycle link followed
       uri <- parseUri link
       case toString <$> uriScheme uri of
         Just "http" -> checkHttp uri
@@ -768,16 +767,14 @@ checkExternalResource followed config@Config{..} link
         InvalidUrlException{} -> error "External link URL invalid exception"
         HttpExceptionRequest _ exc -> case exc of
           StatusCodeException resp _
-            | Just outcome <- redirectRule link code ncExternalRefRedirects ->
-                case outcome of
+            | Just RedirectRule{..} <- redirectRule link code ncExternalRefRedirects ->
+                case rrOutcome of
                   RROValid -> Right RRDone
-                  RROInvalid -> Left $ RedirectRuleError (link : followed)
+                  RROInvalid -> Left $ RedirectRuleError rrOn link followed redirectLocation
                   RROFollow ->
                     case redirectLocation of
-                      Nothing -> Left $ RedirectNoLocation (link : followed)
+                      Nothing -> Left $ RedirectChainBroken link followed
                       Just nextLink -> Right $ RRFollow nextLink
-            | isPermanentRedirectCode code -> Left $ PermanentRedirectError link redirectLocation
-            | isTemporaryRedirectCode code -> Right RRDone
             | isAllowedErrorCode code -> Right RRDone
             | otherwise -> case statusCode (responseStatus resp) of
               429 -> Left . ExternalHttpTooManyRequests $ retryAfterInfo resp

tests/Test/Xrefcheck/RedirectRequestsSpec.hs

@@ -16,6 +16,7 @@ import Test.Tasty.HUnit (Assertion, testCase)
 import Web.Firefly (ToResponse (toResponse), route, run)
 
 import Test.Xrefcheck.UtilRequests
+import Xrefcheck.Config
 import Xrefcheck.Progress
 import Xrefcheck.Verify
 
@@ -43,7 +44,7 @@ test_redirectRequests = testGroup "Redirect response tests"
       redirectTests
         (show statusCode <> " fails by default")
         (mkStatus statusCode "Permanent redirect")
-        (Just . PermanentRedirectError url)
+        (Just . RedirectRuleError (Just RROPermanent) url [])
 
     redirectTests :: TestName -> Status -> (Maybe Text -> Maybe VerifyError) -> TestTree
     redirectTests name expectedStatus expectedError =

tests/configs/github-config.yaml

@@ -46,8 +46,14 @@ networking:
   maxRetries: 3
 
   # Rules to override the redirect behavior for external references that
-  # match. An example rule is {to: *, outcome: valid, on: permanent}
-  externalRefRedirects: []
+  # match.
+  externalRefRedirects:
+    - to: .*
+      on: permanent
+      outcome: invalid
+    - to: .*
+      on: temporary
+      outcome: valid
 
 # Parameters of scanners for various file types.
 scanners: