{- 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
  { RedirectRule -> Maybe Regex
rrFrom :: Maybe Regex
    -- ^ Redirect source links that match to apply the rule.
    --
    -- 'Nothing' matches any link.
  , RedirectRule -> Maybe Regex
rrTo :: Maybe Regex
    -- ^ Redirect target links that match to apply the rule.
    --
    -- 'Nothing' matches any link.
  , RedirectRule -> Maybe RedirectRuleOn
rrOn :: Maybe RedirectRuleOn
    -- ^ HTTP code selector to apply the rule.
    --
    -- 'Nothing' matches any code.
  , RedirectRule -> RedirectRuleOutcome
rrOutcome :: RedirectRuleOutcome
    -- ^ What to do when an HTTP response matches the rule.
  } deriving stock ((forall x. RedirectRule -> Rep RedirectRule x)
-> (forall x. Rep RedirectRule x -> RedirectRule)
-> Generic RedirectRule
forall x. Rep RedirectRule x -> RedirectRule
forall x. RedirectRule -> Rep RedirectRule x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RedirectRule -> Rep RedirectRule x
from :: forall x. RedirectRule -> Rep RedirectRule x
$cto :: forall x. Rep RedirectRule x -> RedirectRule
to :: forall x. Rep RedirectRule x -> RedirectRule
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 (Int -> RedirectRuleOn -> ShowS
[RedirectRuleOn] -> ShowS
RedirectRuleOn -> String
(Int -> RedirectRuleOn -> ShowS)
-> (RedirectRuleOn -> String)
-> ([RedirectRuleOn] -> ShowS)
-> Show RedirectRuleOn
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RedirectRuleOn -> ShowS
showsPrec :: Int -> RedirectRuleOn -> ShowS
$cshow :: RedirectRuleOn -> String
show :: RedirectRuleOn -> String
$cshowList :: [RedirectRuleOn] -> ShowS
showList :: [RedirectRuleOn] -> ShowS
Show, RedirectRuleOn -> RedirectRuleOn -> Bool
(RedirectRuleOn -> RedirectRuleOn -> Bool)
-> (RedirectRuleOn -> RedirectRuleOn -> Bool) -> Eq RedirectRuleOn
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RedirectRuleOn -> RedirectRuleOn -> Bool
== :: RedirectRuleOn -> RedirectRuleOn -> Bool
$c/= :: RedirectRuleOn -> RedirectRuleOn -> Bool
/= :: RedirectRuleOn -> RedirectRuleOn -> Bool
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 (Int -> RedirectRuleOutcome -> ShowS
[RedirectRuleOutcome] -> ShowS
RedirectRuleOutcome -> String
(Int -> RedirectRuleOutcome -> ShowS)
-> (RedirectRuleOutcome -> String)
-> ([RedirectRuleOutcome] -> ShowS)
-> Show RedirectRuleOutcome
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RedirectRuleOutcome -> ShowS
showsPrec :: Int -> RedirectRuleOutcome -> ShowS
$cshow :: RedirectRuleOutcome -> String
show :: RedirectRuleOutcome -> String
$cshowList :: [RedirectRuleOutcome] -> ShowS
showList :: [RedirectRuleOutcome] -> ShowS
Show, RedirectRuleOutcome -> RedirectRuleOutcome -> Bool
(RedirectRuleOutcome -> RedirectRuleOutcome -> Bool)
-> (RedirectRuleOutcome -> RedirectRuleOutcome -> Bool)
-> Eq RedirectRuleOutcome
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RedirectRuleOutcome -> RedirectRuleOutcome -> Bool
== :: RedirectRuleOutcome -> RedirectRuleOutcome -> Bool
$c/= :: RedirectRuleOutcome -> RedirectRuleOutcome -> Bool
/= :: RedirectRuleOutcome -> RedirectRuleOutcome -> Bool
Eq)

-- | Links in a redirection chain.
newtype RedirectChain = RedirectChain
  { RedirectChain -> Seq RedirectChainLink
unRedirectChain :: Seq RedirectChainLink
  } deriving newtype (Int -> RedirectChain -> ShowS
[RedirectChain] -> ShowS
RedirectChain -> String
(Int -> RedirectChain -> ShowS)
-> (RedirectChain -> String)
-> ([RedirectChain] -> ShowS)
-> Show RedirectChain
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RedirectChain -> ShowS
showsPrec :: Int -> RedirectChain -> ShowS
$cshow :: RedirectChain -> String
show :: RedirectChain -> String
$cshowList :: [RedirectChain] -> ShowS
showList :: [RedirectChain] -> ShowS
Show, RedirectChain -> RedirectChain -> Bool
(RedirectChain -> RedirectChain -> Bool)
-> (RedirectChain -> RedirectChain -> Bool) -> Eq RedirectChain
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RedirectChain -> RedirectChain -> Bool
== :: RedirectChain -> RedirectChain -> Bool
$c/= :: RedirectChain -> RedirectChain -> Bool
/= :: RedirectChain -> RedirectChain -> Bool
Eq)

-- | A single link in a redirection chain.
newtype RedirectChainLink = RedirectChainLink
  { RedirectChainLink -> Text
unRedirectChainLink :: Text
  } deriving newtype (Int -> RedirectChainLink -> ShowS
[RedirectChainLink] -> ShowS
RedirectChainLink -> String
(Int -> RedirectChainLink -> ShowS)
-> (RedirectChainLink -> String)
-> ([RedirectChainLink] -> ShowS)
-> Show RedirectChainLink
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RedirectChainLink -> ShowS
showsPrec :: Int -> RedirectChainLink -> ShowS
$cshow :: RedirectChainLink -> String
show :: RedirectChainLink -> String
$cshowList :: [RedirectChainLink] -> ShowS
showList :: [RedirectChainLink] -> ShowS
Show, RedirectChainLink -> RedirectChainLink -> Bool
(RedirectChainLink -> RedirectChainLink -> Bool)
-> (RedirectChainLink -> RedirectChainLink -> Bool)
-> Eq RedirectChainLink
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RedirectChainLink -> RedirectChainLink -> Bool
== :: RedirectChainLink -> RedirectChainLink -> Bool
$c/= :: RedirectChainLink -> RedirectChainLink -> Bool
/= :: RedirectChainLink -> RedirectChainLink -> Bool
Eq)

instance FromList RedirectChain where
  type ListElement RedirectChain = Text
  fromList :: FromListC RedirectChain =>
[ListElement RedirectChain] -> RedirectChain
fromList = Seq RedirectChainLink -> RedirectChain
RedirectChain (Seq RedirectChainLink -> RedirectChain)
-> ([Text] -> Seq RedirectChainLink) -> [Text] -> RedirectChain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ListElement (Seq RedirectChainLink)] -> Seq RedirectChainLink
[RedirectChainLink] -> Seq RedirectChainLink
forall l. (FromList l, FromListC l) => [ListElement l] -> l
fromList ([RedirectChainLink] -> Seq RedirectChainLink)
-> ([Text] -> [RedirectChainLink])
-> [Text]
-> Seq RedirectChainLink
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> RedirectChainLink) -> [Text] -> [RedirectChainLink]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> RedirectChainLink
RedirectChainLink

emptyChain :: RedirectChain
emptyChain :: RedirectChain
emptyChain = Seq RedirectChainLink -> RedirectChain
RedirectChain Seq RedirectChainLink
forall a. Monoid a => a
mempty

pushRequest :: RedirectChain -> RedirectChainLink -> RedirectChain
pushRequest :: RedirectChain -> RedirectChainLink -> RedirectChain
pushRequest (RedirectChain Seq RedirectChainLink
chain) = Seq RedirectChainLink -> RedirectChain
RedirectChain (Seq RedirectChainLink -> RedirectChain)
-> (RedirectChainLink -> Seq RedirectChainLink)
-> RedirectChainLink
-> RedirectChain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seq RedirectChainLink
chain Seq RedirectChainLink -> RedirectChainLink -> Seq RedirectChainLink
forall a. Seq a -> a -> Seq a
|>)

hasRequest :: RedirectChain -> RedirectChainLink -> Bool
hasRequest :: RedirectChain -> RedirectChainLink -> Bool
hasRequest (RedirectChain Seq RedirectChainLink
chain) = (Element (Seq RedirectChainLink) -> Seq RedirectChainLink -> Bool
forall t. (Container t, Eq (Element t)) => Element t -> t -> Bool
`elem` Seq RedirectChainLink
chain)

totalFollowed :: RedirectChain -> Int
totalFollowed :: RedirectChain -> Int
totalFollowed = Seq RedirectChainLink -> Int
forall t. Container t => t -> Int
length (Seq RedirectChainLink -> Int)
-> (RedirectChain -> Seq RedirectChainLink) -> RedirectChain -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RedirectChain -> Seq RedirectChainLink
unRedirectChain

instance Buildable RedirectChain where
  build :: RedirectChain -> Builder
build (RedirectChain Seq RedirectChainLink
linksStack) = Text -> Builder
forall p. Buildable p => p -> Builder
build Text
chainText
    where
      link :: (Bool, RedirectChainLink) -> Text
link (Bool
True, RedirectChainLink Text
l) = Text
"-| " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l
      link (Bool
False, RedirectChainLink Text
l) = Text
"-> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l

      chainText :: Text
chainText = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
"\n"
        ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ ((Bool, RedirectChainLink) -> Text)
-> [(Bool, RedirectChainLink)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool, RedirectChainLink) -> Text
link
        ([(Bool, RedirectChainLink)] -> [Text])
-> [(Bool, RedirectChainLink)] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Bool] -> [RedirectChainLink] -> [(Bool, RedirectChainLink)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Bool
True Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False)
        ([RedirectChainLink] -> [(Bool, RedirectChainLink)])
-> [RedirectChainLink] -> [(Bool, RedirectChainLink)]
forall a b. (a -> b) -> a -> b
$ Seq RedirectChainLink -> [Element (Seq RedirectChainLink)]
forall t. Container t => t -> [Element t]
toList Seq RedirectChainLink
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 :: Text -> Text -> Int -> [RedirectRule] -> Maybe RedirectRule
redirectRule Text
source Text
target Int
code [RedirectRule]
rules =
  (Element [RedirectRule] -> Bool)
-> [RedirectRule] -> Maybe (Element [RedirectRule])
forall t.
Container t =>
(Element t -> Bool) -> t -> Maybe (Element t)
find (Text -> Text -> Int -> RedirectRule -> Bool
matchRule Text
source Text
target Int
code) [RedirectRule]
rules

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

    matchLink :: Text -> Maybe Regex -> Bool
matchLink Text
link = \case
      Maybe Regex
Nothing -> Bool
True
      Just Regex
regex -> Text -> [Regex] -> Bool
doesMatchAnyRegex Text
link [Regex
regex]

isRedirectCode :: Int -> Bool
isRedirectCode :: Int -> Bool
isRedirectCode Int
code = Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
300 Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
400

isTemporaryRedirectCode :: Int -> Bool
isTemporaryRedirectCode :: Int -> Bool
isTemporaryRedirectCode = (Int -> [Int] -> Bool) -> [Int] -> Int -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> [Int] -> Bool
Element [Int] -> [Int] -> Bool
forall t. (Container t, Eq (Element t)) => Element t -> t -> Bool
elem [Int
302, Int
303, Int
307]

isPermanentRedirectCode :: Int -> Bool
isPermanentRedirectCode :: Int -> Bool
isPermanentRedirectCode = (Int -> [Int] -> Bool) -> [Int] -> Int -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> [Int] -> Bool
Element [Int] -> [Int] -> Bool
forall t. (Container t, Eq (Element t)) => Element t -> t -> Bool
elem [Int
301, Int
308]

instance FromJSON (RedirectRule) where
  parseJSON :: Value -> Parser RedirectRule
parseJSON = Options -> Value -> Parser RedirectRule
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
aesonConfigOption

instance FromJSON (RedirectRuleOutcome) where
  parseJSON :: Value -> Parser RedirectRuleOutcome
parseJSON = String
-> (Text -> Parser RedirectRuleOutcome)
-> Value
-> Parser RedirectRuleOutcome
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Redirect rule outcome" ((Text -> Parser RedirectRuleOutcome)
 -> Value -> Parser RedirectRuleOutcome)
-> (Text -> Parser RedirectRuleOutcome)
-> Value
-> Parser RedirectRuleOutcome
forall a b. (a -> b) -> a -> b
$
    \case
      Text
"valid" -> RedirectRuleOutcome -> Parser RedirectRuleOutcome
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RedirectRuleOutcome
RROValid
      Text
"invalid" -> RedirectRuleOutcome -> Parser RedirectRuleOutcome
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RedirectRuleOutcome
RROInvalid
      Text
"follow" -> RedirectRuleOutcome -> Parser RedirectRuleOutcome
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RedirectRuleOutcome
RROFollow
      Text
_ -> String -> Parser RedirectRuleOutcome
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected (valid|invalid|follow)"

instance FromJSON (RedirectRuleOn) where
  parseJSON :: Value -> Parser RedirectRuleOn
parseJSON Value
v = Value -> Parser RedirectRuleOn
code Value
v
    Parser RedirectRuleOn
-> Parser RedirectRuleOn -> Parser RedirectRuleOn
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Parser RedirectRuleOn
text Value
v
    Parser RedirectRuleOn
-> Parser RedirectRuleOn -> Parser RedirectRuleOn
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser RedirectRuleOn
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected a redirect (3XX) HTTP code or (permanent|temporary)"
    where
      code :: Value -> Parser RedirectRuleOn
code Value
cv = do
        Int
i <- Value -> Parser Int
forall a. FromJSON a => Value -> Parser a
parseJSON Value
cv
        Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Parser ()) -> Bool -> Parser ()
forall a b. (a -> b) -> a -> b
$ Int -> Bool
isRedirectCode Int
i
        RedirectRuleOn -> Parser RedirectRuleOn
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RedirectRuleOn -> Parser RedirectRuleOn)
-> RedirectRuleOn -> Parser RedirectRuleOn
forall a b. (a -> b) -> a -> b
$ Int -> RedirectRuleOn
RROCode Int
i
      text :: Value -> Parser RedirectRuleOn
text = String
-> (Text -> Parser RedirectRuleOn)
-> Value
-> Parser RedirectRuleOn
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Redirect rule on" ((Text -> Parser RedirectRuleOn) -> Value -> Parser RedirectRuleOn)
-> (Text -> Parser RedirectRuleOn)
-> Value
-> Parser RedirectRuleOn
forall a b. (a -> b) -> a -> b
$
        \case
          Text
"permanent" -> RedirectRuleOn -> Parser RedirectRuleOn
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RedirectRuleOn
RROPermanent
          Text
"temporary" -> RedirectRuleOn -> Parser RedirectRuleOn
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RedirectRuleOn
RROTemporary
          Text
_ -> Parser RedirectRuleOn
forall a. Parser a
forall (m :: * -> *) a. MonadPlus m => m a
mzero