Config.hs

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

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

module Xrefcheck.Config
  ( module Xrefcheck.Config
  , module Xrefcheck.Data.Redirect
  , defConfigText
  ) where

import Universum hiding ((.~))

import Control.Lens (makeLensesWith, (.~))
import Data.Aeson (genericParseJSON)
import Data.Yaml (FromJSON (..), decodeEither', prettyPrintParseException, withText)
import Text.Regex.TDFA.Text ()
import Time (KnownRatName, Second, Time (..), unitsP)

import Xrefcheck.Config.Default
import Xrefcheck.Core
import Xrefcheck.Data.Redirect
import Xrefcheck.Scan
import Xrefcheck.Scanners.Markdown
import Xrefcheck.Util (Field, aesonConfigOption, postfixFields)

-- | Type alias for Config' with all required fields.
type Config = Config' Identity

-- | Type alias for Config' with optional fields.
type ConfigOptional = Config' Maybe

-- | Overall config.
data Config' f = Config
  { cExclusions :: Field f (ExclusionConfig' f)
  , cNetworking :: Field f (NetworkingConfig' f)
  , cScanners   :: ScannersConfig' f
  } deriving stock (Generic)

-- | Type alias for NetworkingConfig' with all required fields.
type NetworkingConfig = NetworkingConfig' Identity

-- | Config of networking.
data NetworkingConfig' f = NetworkingConfig
  { ncExternalRefCheckTimeout   :: Field f (Time Second)
    -- ^ When checking external references, how long to wait on request before
    -- declaring "Response timeout".
  , ncIgnoreAuthFailures        :: Field f Bool
    -- ^ If True - links which return 403 or 401 code will be skipped,
    -- otherwise – will be marked as broken, because we can't check it.
  , ncDefaultRetryAfter         :: Field f (Time Second)
    -- ^ Default Retry-After delay, applicable when we receive a 429 response
    -- and it does not contain a @Retry-After@ header.
  , ncMaxRetries                :: Field f Int
    -- ^ How many attempts to retry an external link after getting
    -- a "429 Too Many Requests" response.
    -- Timeouts may also be accounted here, see the description
    -- of `maxTimeoutRetries` field.
    --
    -- If a site once responded with 429 error code, subsequent
    -- request timeouts will also be treated as hitting the site's
    -- rate limiter and result in retry attempts, unless the
    -- maximum retries number has been reached.
    --
    -- On other errors xrefcheck fails immediately, without retrying.
  , ncMaxTimeoutRetries         :: Field f Int
    -- ^ Querying a given domain that ever returned 429 before,
    -- this defines how many timeouts are allowed during retries.
    --
    -- For such domains, timeouts likely mean hitting the rate limiter,
    -- and so xrefcheck considers timeouts in the same way as 429 errors.
    --
    -- For other domains, a timeout results in a respective error, no retry
    -- attempts will be performed. Use `externalRefCheckTimeout` option
    -- to increase the time after which timeout is declared.
    --
    -- This option is similar to `maxRetries`, the difference is that
    -- this `maxTimeoutRetries` option limits only the number of retries
    -- caused by timeouts, and `maxRetries` limits the number of retries
    -- caused both by 429s and timeouts.
  , ncMaxRedirectFollows        :: Field f Int
    -- ^ Maximum number of links that can be followed in a single redirect
    -- chain.
  , ncExternalRefRedirects      :: Field f RedirectConfig
    -- ^  Rules to override the redirect behavior for external references.
  } deriving stock (Generic)

-- | A list of custom redirect rules.
type RedirectConfig = [RedirectRule]

-- | Type alias for ScannersConfig' with all required fields.
type ScannersConfig = ScannersConfig' Identity

-- | Configs for all the supported scanners.
data ScannersConfig' f = ScannersConfig
  { scMarkdown :: MarkdownConfig
  , scAnchorSimilarityThreshold :: Field f Double
    -- ^ On 'anchor not found' error, how much similar anchors should be displayed as
    -- hint. Number should be between 0 and 1, larger value means stricter filter.
  } deriving stock (Generic)

makeLensesWith postfixFields ''Config'
makeLensesWith postfixFields ''NetworkingConfig'

defConfig :: HasCallStack => Flavor -> Config
defConfig = either (error . toText . prettyPrintParseException) id
    . decodeEither'
    . encodeUtf8
    . defConfigText

-- | Override missed fields with default values.
overrideConfig :: ConfigOptional -> Config
overrideConfig config
  = Config
    { cExclusions = maybe defExclusions overrideExclusions $ cExclusions config
    , cNetworking = maybe defNetworking overrideNetworking $ cNetworking config
    , cScanners = ScannersConfig
                  { scMarkdown = MarkdownConfig flavor
                  , scAnchorSimilarityThreshold =
                    fromMaybe (scAnchorSimilarityThreshold defScanners)
                    $ scAnchorSimilarityThreshold (cScanners config)
                  }
    }
  where
    flavor = mcFlavor . scMarkdown $ cScanners config

    defScanners = cScanners $ defConfig flavor
    defExclusions = cExclusions $ defConfig flavor
    defNetworking = cNetworking (defConfig flavor)
      & ncExternalRefRedirectsL .~ []

    overrideExclusions exclusionConfig
      = ExclusionConfig
        { ecIgnore               = overrideField ecIgnore
        , ecIgnoreLocalRefsTo    = overrideField ecIgnoreLocalRefsTo
        , ecIgnoreRefsFrom       = overrideField ecIgnoreRefsFrom
        , ecIgnoreExternalRefsTo = overrideField ecIgnoreExternalRefsTo
        }
      where
        overrideField :: (forall f. ExclusionConfig' f -> Field f a) -> a
        overrideField field = fromMaybe (field defExclusions) $ field exclusionConfig

    overrideNetworking networkingConfig
      = NetworkingConfig
        { ncExternalRefCheckTimeout   = overrideField ncExternalRefCheckTimeout
        , ncIgnoreAuthFailures        = overrideField ncIgnoreAuthFailures
        , ncDefaultRetryAfter         = overrideField ncDefaultRetryAfter
        , ncMaxRetries                = overrideField ncMaxRetries
        , ncMaxTimeoutRetries         = overrideField ncMaxTimeoutRetries
        , ncMaxRedirectFollows        = overrideField ncMaxRedirectFollows
        , ncExternalRefRedirects      = overrideField ncExternalRefRedirects
        }
      where
        overrideField :: (forall f. NetworkingConfig' f -> Field f a) -> a
        overrideField field = fromMaybe (field defNetworking) $ field networkingConfig

-----------------------------------------------------------
-- Yaml instances
-----------------------------------------------------------

instance KnownRatName unit => FromJSON (Time unit) where
  parseJSON = withText "time" $
    maybe (fail "Unknown time") pure . unitsP . toString

instance FromJSON (ConfigOptional) where
  parseJSON = genericParseJSON aesonConfigOption

instance FromJSON (Config) where
  parseJSON = genericParseJSON aesonConfigOption

instance FromJSON (NetworkingConfig' Maybe) where
  parseJSON = genericParseJSON aesonConfigOption

instance FromJSON (NetworkingConfig) where
  parseJSON = genericParseJSON aesonConfigOption

instance FromJSON (ScannersConfig) where
  parseJSON = genericParseJSON aesonConfigOption

instance FromJSON (ScannersConfig' Maybe) where
  parseJSON = genericParseJSON aesonConfigOption