[#25] Redirect chain tests

Some tests for testing errors related to redirect chains: broken chains
and cycles.

tests/Test/Xrefcheck/RedirectChainSpec.hs

@@ -0,0 +1,91 @@
+{- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>
+ -
+ - SPDX-License-Identifier: MPL-2.0
+ -}
+
+module Test.Xrefcheck.RedirectChainSpec where
+
+import Universum
+
+import Data.CaseInsensitive qualified as CI
+import Data.Map qualified as M
+import Network.HTTP.Types (mkStatus)
+import Network.HTTP.Types.Header (hLocation)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (testCase)
+import Web.Firefly (App, ToResponse (toResponse), route, run)
+
+import Test.Xrefcheck.UtilRequests
+import Xrefcheck.Config
+import Xrefcheck.Progress
+import Xrefcheck.Verify
+
+test_redirectRequests :: TestTree
+test_redirectRequests = testGroup "Redirect chain tests"
+  [ testCase "Broken" $
+      checkLinkAndProgressWithServer
+        config
+        mockRedirect
+        brokenStart
+        progress
+        (VerifyResult [RedirectChainBroken brokenEnd brokenStack])
+    , testCase "Cycle" $
+        checkLinkAndProgressWithServer
+        config
+        mockRedirect
+        cycleStart
+        progress
+        (VerifyResult [RedirectChainCycle cycleEnd cycleStack])
+  ]
+  where
+    brokenStart :: Text
+    brokenStart = "http://127.0.0.1:5000/broken1"
+
+    brokenEnd :: Text
+    brokenEnd = "http://127.0.0.1:5000/broken3"
+
+    brokenStack :: [Text]
+    brokenStack = fmap ("http://127.0.0.1:5000" <>) ["/broken2", "/broken1"]
+
+    cycleStart :: Text
+    cycleStart = "http://127.0.0.1:5000/cycle1"
+
+    cycleEnd :: Text
+    cycleEnd = "http://127.0.0.1:5000/cycle2"
+
+    cycleStack :: [Text]
+    cycleStack = fmap ("http://127.0.0.1:5000" <>) ["/cycle4", "/cycle3", "/cycle2", "/cycle1"]
+
+    progress :: Progress Int
+    progress = Progress
+      { pTotal = 1
+      , pCurrent = 1
+      , pErrorsUnfixable = 1
+      , pErrorsFixable = 0
+      , pTaskTimestamp = Nothing
+      }
+
+    config :: Config
+    config = localConfig
+      & cNetworkingL . ncExternalRefRedirectsL .~ [RedirectRule Nothing Nothing RROFollow]
+
+    redirectRoute :: Text -> Maybe Text -> App ()
+    redirectRoute name to = route name $ pure $ toResponse
+      ( "" :: Text
+      , mkStatus 301 "Permanent redirect"
+      , M.fromList [(CI.map (decodeUtf8 @Text) hLocation, fmap ("http://127.0.0.1:5000" <>) $ maybeToList to)]
+      )
+
+    mockRedirect :: IO ()
+    mockRedirect =
+      run 5000 do
+        -- A set of redirect routes that correspond to a broken chain.
+        redirectRoute "/broken1" $ Just "/broken2"
+        redirectRoute "/broken2" $ Just "/broken3"
+        redirectRoute "/broken3" Nothing
+
+        -- A set of redirect routes that correspond to a cycle.
+        redirectRoute "/cycle1" $ Just "/cycle2"
+        redirectRoute "/cycle2" $ Just "/cycle3"
+        redirectRoute "/cycle3" $ Just "/cycle4"
+        redirectRoute "/cycle4" $ Just "/cycle2"

tests/Test/Xrefcheck/RedirectRequestsSpec.hs

@@ -1,4 +1,4 @@
-{- SPDX-FileCopyrightText: 2021 Serokell <https://serokell.io>
+{- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>
  -
  - SPDX-License-Identifier: MPL-2.0
  -}
@@ -58,7 +58,7 @@ test_redirectRequests = testGroup "Redirect response tests"
 
     redirectAssertion :: Status -> Maybe Text -> Maybe VerifyError -> Assertion
     redirectAssertion expectedStatus expectedLocation expectedError =
-      checkLinkAndProgressWithServer
+      checkLinkAndProgressWithServer localConfig
         (mockRedirect expectedLocation expectedStatus)
         url
         (Progress
@@ -72,9 +72,9 @@ test_redirectRequests = testGroup "Redirect response tests"
         (VerifyResult $ maybeToList expectedError)
 
     mockRedirect :: Maybe Text -> Status -> IO ()
-    mockRedirect expectedLocation expectedSocation =
+    mockRedirect expectedLocation expectedStatus =
       run 5000 $ route "/redirect" $ pure $ toResponse
         ( "" :: Text
-        , expectedSocation
+        , expectedStatus
         , M.fromList [(CI.map (decodeUtf8 @Text) hLocation, maybeToList expectedLocation)]
         )

tests/Test/Xrefcheck/TooManyRequestsSpec.hs

@@ -35,7 +35,7 @@ test_tooManyRequests = testGroup "429 response tests"
                           , pErrorsFixable = 0
                           , pTaskTimestamp = Nothing
                           }
-      checkLinkAndProgressWithServer (mock429 "1" ok200)
+      checkLinkAndProgressWithServer localConfig (mock429 "1" ok200)
         "http://127.0.0.1:5000/429" prog $ VerifyResult []
   , testCase "Returns 503 eventually" $ do
       let prog = Progress{ pTotal = 1
@@ -44,7 +44,7 @@ test_tooManyRequests = testGroup "429 response tests"
                          , pErrorsFixable = 0
                          , pTaskTimestamp = Nothing
                          }
-      checkLinkAndProgressWithServer (mock429 "1" serviceUnavailable503)
+      checkLinkAndProgressWithServer localConfig (mock429 "1" serviceUnavailable503)
         "http://127.0.0.1:5000/429" prog $ VerifyResult
           [ ExternalHttpResourceUnavailable $
               Status { statusCode = 503, statusMessage = "Service Unavailable"}
@@ -63,6 +63,7 @@ test_tooManyRequests = testGroup "429 response tests"
                   }
               }
         _ <- verifyReferenceWithProgress
+          localConfig
           (Reference "" "http://127.0.0.1:5000/429" Nothing (Position Nothing))
           progressRef
         Progress{..} <- vrExternal <$> readIORef progressRef
@@ -88,6 +89,7 @@ test_tooManyRequests = testGroup "429 response tests"
                   }
               }
         _ <- verifyReferenceWithProgress
+          localConfig
           (Reference "" "http://127.0.0.1:5000/429" Nothing (Position Nothing))
           progressRef
         Progress{..} <- vrExternal <$> readIORef progressRef
@@ -114,6 +116,7 @@ test_tooManyRequests = testGroup "429 response tests"
                   }
               }
         _ <- verifyReferenceWithProgress
+          localConfig
           (Reference "" "http://127.0.0.1:5000/429" Nothing (Position Nothing))
           progressRef
         Progress{..} <- vrExternal <$> readIORef progressRef
@@ -148,7 +151,7 @@ test_tooManyRequests = testGroup "429 response tests"
                 | otherwise -> toResponse ("" :: Text, serviceUnavailable503)
       infoReverseAccumulatorRef <- newIORef []
       E.bracket (forkIO $ mock429WithGlobalIORef infoReverseAccumulatorRef) killThread $ \_ -> do
-        _ <- verifyLink "http://127.0.0.1:5000/429grandfinale"
+        _ <- verifyLink localConfig "http://127.0.0.1:5000/429grandfinale"
         infoReverseAccumulator <- readIORef infoReverseAccumulatorRef
         reverse infoReverseAccumulator @?=
           [ ("HEAD", tooManyRequests429)

tests/Test/Xrefcheck/UtilRequests.hs

@@ -5,6 +5,7 @@
 
 module Test.Xrefcheck.UtilRequests
   ( checkLinkAndProgressWithServer
+  , localConfig
   , verifyLink
   , verifyReferenceWithProgress
   ) where
@@ -24,15 +25,20 @@ import Xrefcheck.Scan
 import Xrefcheck.Util
 import Xrefcheck.Verify
 
+localConfig :: Config
+localConfig = defConfig GitHub
+  & cExclusionsL . ecIgnoreExternalRefsToL .~ []
+
 checkLinkAndProgressWithServer
-  :: IO ()
+  :: Config
+  -> IO ()
   -> Text
   -> Progress Int
   -> VerifyResult VerifyError
   -> IO ()
-checkLinkAndProgressWithServer mock link progress vrExpectation =
+checkLinkAndProgressWithServer config mock link progress vrExpectation =
       E.bracket (forkIO mock) killThread $ \_ -> do
-        (result, progRes) <- verifyLink link
+        (result, progRes) <- verifyLink config link
         flip assertBool (result == vrExpectation) $
           [int||
           Verification results differ: expected
@@ -60,16 +66,14 @@ checkLinkAndProgressWithServer mock link progress vrExpectation =
                           , ((==) `on` pErrorsFixable) p1 p2
                           ]
 
-verifyLink :: Text -> IO (VerifyResult VerifyError, Progress Int)
-verifyLink link = do
+verifyLink :: Config -> Text -> IO (VerifyResult VerifyError, Progress Int)
+verifyLink config link = do
   let reference = Reference "" link Nothing (Position Nothing)
   progRef <- newIORef $ initVerifyProgress [reference]
-  result <- verifyReferenceWithProgress reference progRef
+  result <- verifyReferenceWithProgress config reference progRef
   p <- readIORef progRef
   return (result, vrExternal p)
 
-verifyReferenceWithProgress :: Reference -> IORef VerifyProgress -> IO (VerifyResult VerifyError)
-verifyReferenceWithProgress reference progRef = do
-  fmap wrlItem <$> verifyReference
-    (defConfig GitHub & cExclusionsL . ecIgnoreExternalRefsToL .~ []) FullMode
-    progRef (RepoInfo M.empty mempty) "." "" reference
+verifyReferenceWithProgress :: Config -> Reference -> IORef VerifyProgress -> IO (VerifyResult VerifyError)
+verifyReferenceWithProgress config reference progRef = do
+  fmap wrlItem <$> verifyReference config FullMode progRef (RepoInfo M.empty mempty) "." "" reference