RedirectChainSpec.hs

{- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>
 -
 - SPDX-License-Identifier: MPL-2.0
 -}

module Test.Xrefcheck.RedirectChainSpec where

import Universum hiding ((.~))

import Control.Lens ((.~))
import Data.CaseInsensitive qualified as CI
import Network.HTTP.Types (movedPermanently301)
import Network.HTTP.Types.Header (HeaderName, hLocation)
import Network.Wai qualified as Web
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase)
import Web.Scotty qualified as Web

import Test.Xrefcheck.UtilRequests
import Xrefcheck.Config
import Xrefcheck.Progress
import Xrefcheck.Verify

test_redirectRequests :: TestTree
test_redirectRequests = testGroup "Redirect chain tests"
  [ testCase "Missing location" $ do
      setRef <- newIORef mempty
      checkLinkAndProgressWithServer
        (configMod 5)
        setRef
        (5000, mockRedirect)
        (link "/broken1")
        progress
        (VerifyResult [RedirectMissingLocation $ chain [ "/broken1", "/broken2", "/broken3"]])
  , testCase "Cycle" $ do
      setRef <- newIORef mempty
      checkLinkAndProgressWithServer
        (configMod 5)
        setRef
        (5000, mockRedirect)
        (link "/cycle1")
        progress
        (VerifyResult [RedirectChainCycle $ chain ["/cycle1", "/cycle2", "/cycle3", "/cycle4", "/cycle2"]])
  , testGroup "Relative redirect"
      [ testCase "Host" $ do
          setRef <- newIORef mempty
          checkLinkAndProgressWithServer
            (configMod 1)
            setRef
            (5000, mockRedirect)
            (link "/relative/host")
            progress
            (VerifyResult [RedirectChainLimit $ chain ["/relative/host", "/cycle2", "/cycle3"]])
      , testCase "Path" $ do
          setRef <- newIORef mempty
          checkLinkAndProgressWithServer
            (configMod 1)
            setRef
            (5000, mockRedirect)
            (link "/relative/path")
            progress
            (VerifyResult [RedirectChainLimit $ chain ["/relative/path", "/relative/host", "/cycle2"]])
      ]
  , testCase "Other host redirect" $ withServer (5001, otherMockRedirect) $ do
      setRef <- newIORef mempty
      checkLinkAndProgressWithServer
        (configMod 1)
        setRef
        (5000, mockRedirect)
        "http://127.0.0.1:5001/other/host"
        progress
        (VerifyResult [RedirectChainLimit $ fromList ["http://127.0.0.1:5001/other/host", link "/relative/host", link "/cycle2"]])
  , testGroup "Limit"
      [ testCase "Takes effect" $ do
          setRef <- newIORef mempty
          checkLinkAndProgressWithServer
            (configMod 2)
            setRef
            (5000, mockRedirect)
            (link "/cycle1")
            progress
            (VerifyResult [RedirectChainLimit $ chain ["/cycle1", "/cycle2", "/cycle3", "/cycle4"]])
      , testCase "No redirects allowed" $ do
          setRef <- newIORef mempty
          checkLinkAndProgressWithServer
            (configMod 0)
            setRef
            (5000, mockRedirect)
            (link "/cycle1")
            progress
            (VerifyResult [RedirectChainLimit $ chain ["/cycle1", "/cycle2"]])
      , testCase "Negative" $ do
          setRef <- newIORef mempty
          checkLinkAndProgressWithServer
            (configMod (-1))
            setRef
            (5000, mockRedirect)
            (link "/cycle1")
            progress
            (VerifyResult [RedirectChainCycle $ chain ["/cycle1", "/cycle2", "/cycle3", "/cycle4", "/cycle2"]])
      ]
  ]
  where
    link :: Text -> Text
    link = ("http://127.0.0.1:5000" <>)

    chain :: [Text] -> RedirectChain
    chain = fromList . fmap link

    progress :: Progress Int Text
    progress = reportError "" $ initProgress 1

    configMod :: Int -> Config -> Config
    configMod limit config = config
      & cNetworkingL . ncExternalRefRedirectsL .~ [RedirectRule Nothing Nothing Nothing RROFollow]
      & cNetworkingL . ncMaxRedirectFollowsL .~ limit

    setHeader :: HeaderName -> Text -> Web.ActionM ()
    setHeader hdr value = Web.setHeader (decodeUtf8 (CI.original hdr)) (fromStrict value)

    mockRedirect :: IO Web.Application
    mockRedirect = do
      Web.scottyApp $ do
        -- A set of redirect routes that correspond to a broken chain.
        Web.matchAny "/broken1" $ do
          setHeader hLocation (link "/broken2")
          Web.status movedPermanently301
        Web.matchAny "/broken2" $ do
          setHeader hLocation (link "/broken3")
          Web.status movedPermanently301
        Web.matchAny "/broken3" $ do
          -- hLocation: no value
          Web.status movedPermanently301

        -- A set of redirect routes that correspond to a cycle.
        Web.matchAny "/cycle1" $ do
          setHeader hLocation (link "/cycle2")
          Web.status movedPermanently301
        Web.matchAny "/cycle2" $ do
          setHeader hLocation (link "/cycle3")
          Web.status movedPermanently301
        Web.matchAny "/cycle3" $ do
          setHeader hLocation (link "/cycle4")
          Web.status movedPermanently301
        Web.matchAny "/cycle4" $ do
          setHeader hLocation (link "/cycle2")
          Web.status movedPermanently301

        -- Relative redirects.
        Web.matchAny "/relative/host" $ do
          setHeader hLocation "/cycle2"
          Web.status movedPermanently301
        Web.matchAny "/relative/path" $ do
          setHeader hLocation "host"
          Web.status movedPermanently301

    -- To other host
    otherMockRedirect :: IO Web.Application
    otherMockRedirect =
      Web.scottyApp $ Web.matchAny "/other/host" $ do
        setHeader hLocation (link "/relative/host")
        Web.status movedPermanently301