Redirect.hs

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

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Xrefcheck.Data.Redirect
  ( RedirectChain
  , RedirectChainLink (..)
  , emptyChain
  , pushRequest
  , hasRequest
  , totalFollowed

  , RedirectRule (..)
  , RedirectRuleOn (..)
  , RedirectRuleOutcome (..)
  , redirectRule

  , isPermanentRedirectCode
  , isRedirectCode
  , isTemporaryRedirectCode
  ) where

import Universum

import Data.Aeson (genericParseJSON)
import Data.Yaml (FromJSON (..), withText)
import Fmt (Buildable (..))
import Text.Regex.TDFA.Text (Regex)

import Data.Sequence ((|>))
import Xrefcheck.Scan ()
import Xrefcheck.Util

-- | A custom redirect rule.
data RedirectRule = RedirectRule
  { rrFrom :: Maybe Regex
    -- ^ Redirect source links that match to apply the rule.
    --
    -- 'Nothing' matches any link.
  , rrTo :: Maybe Regex
    -- ^ Redirect target links that match to apply the rule.
    --
    -- 'Nothing' matches any link.
  , rrOn :: Maybe RedirectRuleOn
    -- ^ HTTP code selector to apply the rule.
    --
    -- 'Nothing' matches any code.
  , rrOutcome :: RedirectRuleOutcome
    -- ^ What to do when an HTTP response matches the rule.
  } deriving stock (Generic)

-- | Rule selector depending on the response HTTP code.
data RedirectRuleOn
    = RROCode Int
      -- ^ An exact HTTP code
    | RROPermanent
      -- ^ Any HTTP code considered as permanent according to 'isPermanentRedirectCode'
    | RROTemporary
      -- ^ Any HTTP code considered as permanent according to 'isTemporaryRedirectCode'
    deriving stock (Show, Eq)

-- | What to do when receiving a redirect HTTP response.
data RedirectRuleOutcome
    = RROValid
      -- ^ Consider it as valid
    | RROInvalid
      -- ^ Consider it as invalid
    | RROFollow
      -- ^ Try again by following the redirect
    deriving stock (Show, Eq)

-- | Links in a redirection chain.
newtype RedirectChain = RedirectChain
  { unRedirectChain :: Seq RedirectChainLink
  } deriving newtype (Show, Eq)

-- | A single link in a redirection chain.
newtype RedirectChainLink = RedirectChainLink
  { unRedirectChainLink :: Text
  } deriving newtype (Show, Eq)

instance FromList RedirectChain where
  type ListElement RedirectChain = Text
  fromList = RedirectChain . fromList . fmap RedirectChainLink

emptyChain :: RedirectChain
emptyChain = RedirectChain mempty

pushRequest :: RedirectChain -> RedirectChainLink -> RedirectChain
pushRequest (RedirectChain chain) = RedirectChain . (chain |>)

hasRequest :: RedirectChain -> RedirectChainLink -> Bool
hasRequest (RedirectChain chain) = (`elem` chain)

totalFollowed :: RedirectChain -> Int
totalFollowed = length . unRedirectChain

instance Buildable RedirectChain where
  build (RedirectChain linksStack) = build chainText
    where
      link (True, RedirectChainLink l) = "-| " <> l
      link (False, RedirectChainLink l) = "-> " <> l

      chainText = mconcat
        $ intersperse "\n"
        $ fmap link
        $ zip (True : repeat False)
        $ toList linksStack

-- | Redirect rule to apply to a link when it has been responded with a given
-- HTTP code.
redirectRule :: Text -> Text -> Int -> [RedirectRule] -> Maybe RedirectRule
redirectRule source target code rules =
  find (matchRule source target code) rules

-- | Check if a 'RedirectRule' matches a given link and HTTP code.
matchRule :: Text -> Text -> Int -> RedirectRule -> Bool
matchRule source target code RedirectRule{..} = and
  [ matchCode
  , matchLink source rrFrom
  , matchLink target rrTo
  ]
  where
    matchCode = case rrOn of
      Nothing -> True
      Just RROPermanent -> isPermanentRedirectCode code
      Just RROTemporary -> isTemporaryRedirectCode code
      Just (RROCode other) -> code == other

    matchLink link = \case
      Nothing -> True
      Just regex -> doesMatchAnyRegex link [regex]

isRedirectCode :: Int -> Bool
isRedirectCode code = code >= 300 && code < 400

isTemporaryRedirectCode :: Int -> Bool
isTemporaryRedirectCode = flip elem [302, 303, 307]

isPermanentRedirectCode :: Int -> Bool
isPermanentRedirectCode = flip elem [301, 308]

instance FromJSON (RedirectRule) where
  parseJSON = genericParseJSON aesonConfigOption

instance FromJSON (RedirectRuleOutcome) where
  parseJSON = withText "Redirect rule outcome" $
    \case
      "valid" -> pure RROValid
      "invalid" -> pure RROInvalid
      "follow" -> pure RROFollow
      _ -> fail "expected (valid|invalid|follow)"

instance FromJSON (RedirectRuleOn) where
  parseJSON v = code v
    <|> text v
    <|> fail "expected a redirect (3XX) HTTP code or (permanent|temporary)"
    where
      code cv = do
        i <- parseJSON cv
        guard $ isRedirectCode i
        pure $ RROCode i
      text = withText "Redirect rule on" $
        \case
          "permanent" -> pure RROPermanent
          "temporary" -> pure RROTemporary
          _ -> mzero