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

{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE PartialTypeSignatures #-}

module Xrefcheck.Verify
  ( -- * General verification
    VerifyResult (..)
  , verifyErrors
  , verifying

  , RetryAfter (..)
  , WithReferenceLoc (..)

    -- * Concurrent traversal with caching
  , NeedsCaching (..)
  , forConcurrentlyCaching

    -- * Cross-references validation
  , DomainName (..)
  , VerifyError (..)
  , verifyRepo
  , verifyReference
  , checkExternalResource
  , reportVerifyErrs
  ) where

import Universum

import Control.Concurrent.Async (Async, async, cancel, poll, wait, withAsync)
import Control.Exception (AsyncException (..), throwIO)
import Control.Exception.Safe (handleAsync)
import Control.Monad.Except (MonadError (..))
import Data.Bits (toIntegralSized)
import Data.ByteString qualified as BS
import Data.List (lookup)
import Data.List qualified as L
import Data.Map qualified as M
import Data.Reflection (Given)
import Data.Set qualified as S
import Data.Text (toCaseFold)
import Data.Text.Metrics (damerauLevenshteinNorm)
import Data.Time (UTCTime, defaultTimeLocale, formatTime, readPTime, rfc822DateFormat)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Traversable (for)
import Fmt (Buildable (..), Builder, fmt, fmtLn, maybeF, nameF)
import GHC.Exts qualified as Exts
import GHC.Read (Read (readPrec))
import Network.Connection qualified as N.C
import Network.FTP.Client
  (FTPException (..), FTPResponse (..), ResponseStatus (..), login, nlst, size, withFTP, withFTPS)
import Network.HTTP.Client
  (HttpException (..), HttpExceptionContent (..), Response, responseHeaders, responseStatus)
import Network.HTTP.Req
  (AllowsBody, CanHaveBody (NoBody), GET (..), HEAD (..), HttpBodyAllowed,
  HttpConfig (httpConfigRedirectCount), HttpException (..), HttpMethod, NoReqBody (..),
  defaultHttpConfig, ignoreResponse, req, runReq, useURI)
import Network.HTTP.Types.Header (hRetryAfter)
import Network.HTTP.Types.Status (Status, statusCode, statusMessage)
import Text.Interpolation.Nyan
import Text.ParserCombinators.ReadPrec qualified as ReadPrec (lift)
import Text.URI (Authority (..), URI (..), relativeTo, render, unRText)
import Time (RatioNat, Second, Time (..), ms, sec, threadDelay, timeout, (+:+), (-:-))

import Control.Monad.Trans.Except (withExceptT)
import Xrefcheck.Config
import Xrefcheck.Core
import Xrefcheck.Data.URI
import Xrefcheck.Orphans ()
import Xrefcheck.Progress
import Xrefcheck.Scan
import Xrefcheck.Scanners.Markdown (MarkdownConfig (mcFlavor))
import Xrefcheck.System
import Xrefcheck.Util

{-# ANN module ("HLint: ignore Use uncurry" :: Text) #-}
{-# ANN module ("HLint: ignore Use 'runExceptT' from Universum" :: Text) #-}

-----------------------------------------------------------
-- General verification
-----------------------------------------------------------

newtype VerifyResult e = VerifyResult [e]
  deriving newtype (Int -> VerifyResult e -> ShowS
[VerifyResult e] -> ShowS
VerifyResult e -> String
(Int -> VerifyResult e -> ShowS)
-> (VerifyResult e -> String)
-> ([VerifyResult e] -> ShowS)
-> Show (VerifyResult e)
forall e. Show e => Int -> VerifyResult e -> ShowS
forall e. Show e => [VerifyResult e] -> ShowS
forall e. Show e => VerifyResult e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall e. Show e => Int -> VerifyResult e -> ShowS
showsPrec :: Int -> VerifyResult e -> ShowS
$cshow :: forall e. Show e => VerifyResult e -> String
show :: VerifyResult e -> String
$cshowList :: forall e. Show e => [VerifyResult e] -> ShowS
showList :: [VerifyResult e] -> ShowS
Show, VerifyResult e -> VerifyResult e -> Bool
(VerifyResult e -> VerifyResult e -> Bool)
-> (VerifyResult e -> VerifyResult e -> Bool)
-> Eq (VerifyResult e)
forall e. Eq e => VerifyResult e -> VerifyResult e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall e. Eq e => VerifyResult e -> VerifyResult e -> Bool
== :: VerifyResult e -> VerifyResult e -> Bool
$c/= :: forall e. Eq e => VerifyResult e -> VerifyResult e -> Bool
/= :: VerifyResult e -> VerifyResult e -> Bool
Eq, (forall a b. (a -> b) -> VerifyResult a -> VerifyResult b)
-> (forall a b. a -> VerifyResult b -> VerifyResult a)
-> Functor VerifyResult
forall a b. a -> VerifyResult b -> VerifyResult a
forall a b. (a -> b) -> VerifyResult a -> VerifyResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> VerifyResult a -> VerifyResult b
fmap :: forall a b. (a -> b) -> VerifyResult a -> VerifyResult b
$c<$ :: forall a b. a -> VerifyResult b -> VerifyResult a
<$ :: forall a b. a -> VerifyResult b -> VerifyResult a
Functor)

deriving newtype instance Semigroup (VerifyResult e)
deriving newtype instance Monoid (VerifyResult e)

verifyErrors :: VerifyResult e -> Maybe (NonEmpty e)
verifyErrors :: forall e. VerifyResult e -> Maybe (NonEmpty e)
verifyErrors (VerifyResult [e]
errors) = [e] -> Maybe (NonEmpty e)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [e]
errors

verifying :: Monad m => ExceptT e m () -> m (VerifyResult e)
verifying :: forall (m :: * -> *) e.
Monad m =>
ExceptT e m () -> m (VerifyResult e)
verifying (ExceptT m (Either e ())
action) = (Either e () -> VerifyResult e)
-> m (Either e ()) -> m (VerifyResult e)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either e () -> VerifyResult e
forall e. Either e () -> VerifyResult e
toVerifyRes m (Either e ())
action

toVerifyRes :: Either e () -> VerifyResult e
toVerifyRes :: forall e. Either e () -> VerifyResult e
toVerifyRes = [e] -> VerifyResult e
forall e. [e] -> VerifyResult e
VerifyResult ([e] -> VerifyResult e)
-> (Either e () -> [e]) -> Either e () -> VerifyResult e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> [e]) -> (() -> [e]) -> Either e () -> [e]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> [e]
OneItem [e] -> [e]
forall x. One x => OneItem x -> x
one (\() -> [])

-----------------------------------------------------------
-- Cross-references validation
-----------------------------------------------------------

data WithReferenceLoc a = WithReferenceLoc
  { forall a. WithReferenceLoc a -> RelPosixLink
wrlFile      :: RelPosixLink
  , forall a. WithReferenceLoc a -> Reference
wrlReference :: Reference
  , forall a. WithReferenceLoc a -> a
wrlItem      :: a
  }

-- | Contains a name of a domain, examples:
-- @DomainName "github.com"@,
-- @DomainName "localhost"@,
-- @DomainName "192.168.0.104"@
newtype DomainName = DomainName { DomainName -> Text
unDomainName :: Text }
  deriving stock (Int -> DomainName -> ShowS
[DomainName] -> ShowS
DomainName -> String
(Int -> DomainName -> ShowS)
-> (DomainName -> String)
-> ([DomainName] -> ShowS)
-> Show DomainName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DomainName -> ShowS
showsPrec :: Int -> DomainName -> ShowS
$cshow :: DomainName -> String
show :: DomainName -> String
$cshowList :: [DomainName] -> ShowS
showList :: [DomainName] -> ShowS
Show, DomainName -> DomainName -> Bool
(DomainName -> DomainName -> Bool)
-> (DomainName -> DomainName -> Bool) -> Eq DomainName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DomainName -> DomainName -> Bool
== :: DomainName -> DomainName -> Bool
$c/= :: DomainName -> DomainName -> Bool
/= :: DomainName -> DomainName -> Bool
Eq, Eq DomainName
Eq DomainName =>
(DomainName -> DomainName -> Ordering)
-> (DomainName -> DomainName -> Bool)
-> (DomainName -> DomainName -> Bool)
-> (DomainName -> DomainName -> Bool)
-> (DomainName -> DomainName -> Bool)
-> (DomainName -> DomainName -> DomainName)
-> (DomainName -> DomainName -> DomainName)
-> Ord DomainName
DomainName -> DomainName -> Bool
DomainName -> DomainName -> Ordering
DomainName -> DomainName -> DomainName
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DomainName -> DomainName -> Ordering
compare :: DomainName -> DomainName -> Ordering
$c< :: DomainName -> DomainName -> Bool
< :: DomainName -> DomainName -> Bool
$c<= :: DomainName -> DomainName -> Bool
<= :: DomainName -> DomainName -> Bool
$c> :: DomainName -> DomainName -> Bool
> :: DomainName -> DomainName -> Bool
$c>= :: DomainName -> DomainName -> Bool
>= :: DomainName -> DomainName -> Bool
$cmax :: DomainName -> DomainName -> DomainName
max :: DomainName -> DomainName -> DomainName
$cmin :: DomainName -> DomainName -> DomainName
min :: DomainName -> DomainName -> DomainName
Ord)

data VerifyError
  = LocalFileDoesNotExist RelPosixLink
  | LocalFileOutsideRepo RelPosixLink
  | LinkTargetNotAddedToGit RelPosixLink
  | AnchorDoesNotExist Text [Anchor]
  | AmbiguousAnchorRef RelPosixLink Text (NonEmpty Anchor)
  | ExternalResourceUriParseError UriParseError
  | ExternalResourceInvalidUrl (Maybe Text)
  | ExternalResourceUnknownProtocol
  | ExternalHttpResourceUnavailable Status
  | ExternalHttpTooManyRequests (Maybe RetryAfter) (Maybe DomainName)
  | ExternalHttpTimeout (Maybe DomainName)
  | ExternalFtpResourceUnavailable FTPResponse
  | ExternalFtpException FTPException
  | FtpEntryDoesNotExist FilePath
  | ExternalResourceSomeError Text
  | ExternalResourceConnectionFailure
  | RedirectChainCycle RedirectChain
  | RedirectMissingLocation RedirectChain
  | RedirectChainLimit RedirectChain
  | RedirectRuleError RedirectChain (Maybe RedirectRuleOn)
  deriving stock (Int -> VerifyError -> ShowS
[VerifyError] -> ShowS
VerifyError -> String
(Int -> VerifyError -> ShowS)
-> (VerifyError -> String)
-> ([VerifyError] -> ShowS)
-> Show VerifyError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VerifyError -> ShowS
showsPrec :: Int -> VerifyError -> ShowS
$cshow :: VerifyError -> String
show :: VerifyError -> String
$cshowList :: [VerifyError] -> ShowS
showList :: [VerifyError] -> ShowS
Show, VerifyError -> VerifyError -> Bool
(VerifyError -> VerifyError -> Bool)
-> (VerifyError -> VerifyError -> Bool) -> Eq VerifyError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VerifyError -> VerifyError -> Bool
== :: VerifyError -> VerifyError -> Bool
$c/= :: VerifyError -> VerifyError -> Bool
/= :: VerifyError -> VerifyError -> Bool
Eq)

data ResponseResult
  = RRDone
  | RRFollow Text

pprVerifyErr' :: Given ColorMode => ReferenceInfo -> VerifyError -> Builder
pprVerifyErr' :: Given ColorMode => ReferenceInfo -> VerifyError -> Builder
pprVerifyErr' ReferenceInfo
rInfo = \case
    LocalFileDoesNotExist RelPosixLink
file ->
      [int||
      File does not exist:
        #{file}#l{
          if hasBackslash file
          then "\\n  Its reference contains a backslash. Maybe it uses the wrong path separator."
          else ""
        }
      |]

    LocalFileOutsideRepo RelPosixLink
file ->
      [int||
      Link #{pprLinkTyp rInfo} targets a local file outside the repository:
        #{file}
      |]

    LinkTargetNotAddedToGit RelPosixLink
file ->
      [int||
      Link #{pprLinkTyp rInfo} targets a file not tracked by Git:
        #{file}
      Please run "git add" before running xrefcheck or enable --include-untracked CLI option.
      |]

    AnchorDoesNotExist Text
anchor [Anchor]
similar -> case [Anchor] -> Maybe (NonEmpty Anchor)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Anchor]
similar of
      Maybe (NonEmpty Anchor)
Nothing ->
        [int||
        Anchor '#{anchor}' is not present
        |]
      Just NonEmpty Anchor
otherAnchors ->
        [int||
        Anchor '#{anchor}' is not present, did you mean:
        #{interpolateIndentF 2 $ interpolateBlockListF otherAnchors}
        |]

    AmbiguousAnchorRef RelPosixLink
file Text
anchor NonEmpty Anchor
fileAnchors ->
      [int||
      Ambiguous reference to anchor '#{anchor}'
      in file #{file}
      It could refer to either:
      #{interpolateIndentF 2 $ interpolateBlockListF fileAnchors}
      Use of ambiguous anchors is discouraged because the target
      can change silently while the document containing it evolves.
      |]

    ExternalResourceUriParseError (UPEInvalid URIParseError
err) ->
      [int||
      Invalid URI (#{err})
      |] Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Given ColorMode => ReferenceInfo -> Builder
ReferenceInfo -> Builder
pprLinkCtx ReferenceInfo
rInfo

    ExternalResourceUriParseError (UPEConversion ParseExceptionBs
err) ->
      [int||
      Invalid URI
      #{interpolateIndentF 2 . build $ displayException err}
      |] Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Given ColorMode => ReferenceInfo -> Builder
ReferenceInfo -> Builder
pprLinkCtx ReferenceInfo
rInfo

    ExternalResourceInvalidUrl Maybe Text
Nothing ->
      [int||
      Invalid URL
      |] Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Given ColorMode => ReferenceInfo -> Builder
ReferenceInfo -> Builder
pprLinkCtx ReferenceInfo
rInfo

    ExternalResourceInvalidUrl (Just Text
message) ->
      [int||
      Invalid URL (#{message})
      |] Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Given ColorMode => ReferenceInfo -> Builder
ReferenceInfo -> Builder
pprLinkCtx ReferenceInfo
rInfo

    VerifyError
ExternalResourceUnknownProtocol ->
      [int||
      Bad url (expected 'http','https', 'ftp' or 'ftps')
      |] Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Given ColorMode => ReferenceInfo -> Builder
ReferenceInfo -> Builder
pprLinkCtx ReferenceInfo
rInfo

    ExternalHttpResourceUnavailable Status
status ->
      [int||
      Resource unavailable (#{statusCode status} #{decodeUtf8 @Text (statusMessage status)})
      |] Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Given ColorMode => ReferenceInfo -> Builder
ReferenceInfo -> Builder
pprLinkCtx ReferenceInfo
rInfo

    ExternalHttpTooManyRequests Maybe RetryAfter
retryAfter Maybe DomainName
_ ->
      [int||
      Resource unavailable (429 Too Many Requests; retry after #{maybeF retryAfter})
      |] Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Given ColorMode => ReferenceInfo -> Builder
ReferenceInfo -> Builder
pprLinkCtx ReferenceInfo
rInfo

    ExternalHttpTimeout Maybe DomainName
_ ->
      [int||
      Response timeout
      |] Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Given ColorMode => ReferenceInfo -> Builder
ReferenceInfo -> Builder
pprLinkCtx ReferenceInfo
rInfo

    ExternalFtpResourceUnavailable FTPResponse
response ->
      [int||
      Resource unavailable:
      #{response}
      |] Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Given ColorMode => ReferenceInfo -> Builder
ReferenceInfo -> Builder
pprLinkCtx ReferenceInfo
rInfo

    ExternalFtpException FTPException
err ->
      [int||
      FTP exception (#{err})
      |] Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Given ColorMode => ReferenceInfo -> Builder
ReferenceInfo -> Builder
pprLinkCtx ReferenceInfo
rInfo

    FtpEntryDoesNotExist String
entry ->
      [int||
      File or directory does not exist:
      #{entry}
      |]

    ExternalResourceSomeError Text
err ->
      [int||
      #{err}
      |] Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Given ColorMode => ReferenceInfo -> Builder
ReferenceInfo -> Builder
pprLinkCtx ReferenceInfo
rInfo

    VerifyError
ExternalResourceConnectionFailure ->
      [int||
      Connection failure
      |] Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Given ColorMode => ReferenceInfo -> Builder
ReferenceInfo -> Builder
pprLinkCtx ReferenceInfo
rInfo

    RedirectChainCycle RedirectChain
chain ->
      [int||
      Cycle found in the following redirect chain:
      #{interpolateIndentF 2 $ attachToRedirectChain chain "here"}
      |] Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Given ColorMode => ReferenceInfo -> Builder
ReferenceInfo -> Builder
pprLinkCtx ReferenceInfo
rInfo

    RedirectMissingLocation RedirectChain
chain ->
      [int||
      Missing location header in the following redirect chain:
      #{interpolateIndentF 2 $ attachToRedirectChain chain "no location header"}
      |] Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Given ColorMode => ReferenceInfo -> Builder
ReferenceInfo -> Builder
pprLinkCtx ReferenceInfo
rInfo

    RedirectChainLimit RedirectChain
chain ->
        [int||
        The follow redirects limit has been reached in the following redirect chain:
        #{interpolateIndentF 2 $ attachToRedirectChain chain "stopped before this one"}
        |] Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Given ColorMode => ReferenceInfo -> Builder
ReferenceInfo -> Builder
pprLinkCtx ReferenceInfo
rInfo

    RedirectRuleError RedirectChain
chain Maybe RedirectRuleOn
mOn ->
      [int||
      #{redirect} found:
      #{interpolateIndentF 2 $ attachToRedirectChain chain "stopped before this one"}
      |] Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Given ColorMode => ReferenceInfo -> Builder
ReferenceInfo -> Builder
pprLinkCtx ReferenceInfo
rInfo
      where
        redirect :: Text
        redirect :: Text
redirect = case Maybe RedirectRuleOn
mOn of
          Maybe RedirectRuleOn
Nothing -> Text
"Redirect"
          Just RedirectRuleOn
RROPermanent -> Text
"Permanent redirect"
          Just RedirectRuleOn
RROTemporary -> Text
"Temporary redirect"
          Just (RROCode Int
code) -> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
code Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" redirect"

attachToRedirectChain :: RedirectChain -> Text -> Builder
attachToRedirectChain :: RedirectChain -> Text -> Builder
attachToRedirectChain RedirectChain
chain Text
attached
  = RedirectChain -> Builder
forall p. Buildable p => p -> Builder
build RedirectChain
chain Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall p. Buildable p => p -> Builder
build Text
attachedText
  where
    attachedText :: Text
attachedText = Text
"\n   ^-- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attached

data RetryCounter = RetryCounter
  { RetryCounter -> Int
rcTotalRetries   :: Int
  , RetryCounter -> Int
rcTimeoutRetries :: Int
  } deriving stock (Int -> RetryCounter -> ShowS
[RetryCounter] -> ShowS
RetryCounter -> String
(Int -> RetryCounter -> ShowS)
-> (RetryCounter -> String)
-> ([RetryCounter] -> ShowS)
-> Show RetryCounter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RetryCounter -> ShowS
showsPrec :: Int -> RetryCounter -> ShowS
$cshow :: RetryCounter -> String
show :: RetryCounter -> String
$cshowList :: [RetryCounter] -> ShowS
showList :: [RetryCounter] -> ShowS
Show)

incTotalCounter :: RetryCounter -> RetryCounter
incTotalCounter :: RetryCounter -> RetryCounter
incTotalCounter RetryCounter
rc = RetryCounter
rc {rcTotalRetries = rcTotalRetries rc + 1}

incTimeoutCounter :: RetryCounter -> RetryCounter
incTimeoutCounter :: RetryCounter -> RetryCounter
incTimeoutCounter RetryCounter
rc = RetryCounter
rc {rcTimeoutRetries = rcTimeoutRetries rc + 1}

pprVerifyErr :: Given ColorMode => WithReferenceLoc VerifyError -> Builder
pprVerifyErr :: Given ColorMode => WithReferenceLoc VerifyError -> Builder
pprVerifyErr WithReferenceLoc VerifyError
wrl = Builder
hdr Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Int -> Builder -> Builder
Int -> Builder -> Builder
interpolateIndentF Int
2 Builder
msg
  where
    WithReferenceLoc{Reference
wrlReference :: forall a. WithReferenceLoc a -> Reference
wrlReference :: Reference
wrlReference, VerifyError
wrlItem :: forall a. WithReferenceLoc a -> a
wrlItem :: VerifyError
wrlItem} = WithReferenceLoc VerifyError
wrl
    Reference{Text
rName :: Text
rName :: Reference -> Text
rName, ReferenceInfo
rInfo :: ReferenceInfo
rInfo :: Reference -> ReferenceInfo
rInfo} = Reference
wrlReference

    hdr, msg :: Builder
    hdr :: Builder
hdr =
      Style -> Builder -> Builder
forall a. (Pretty a, Given ColorMode) => Style -> a -> a
styleIfNeeded Style
Bold (Position -> Builder
forall p. Buildable p => p -> Builder
build (Reference -> Position
rPos Reference
wrlReference) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
": ") Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
      Color -> Builder -> Builder
forall a. (Pretty a, Given ColorMode) => Color -> a -> a
colorIfNeeded Color
Red Builder
"bad reference:"
    msg :: Builder
msg =
      Builder
"The reference to " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall b a. (Show a, IsString b) => a -> b
show Text
rName Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" failed verification.\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
      Given ColorMode => ReferenceInfo -> VerifyError -> Builder
ReferenceInfo -> VerifyError -> Builder
pprVerifyErr' ReferenceInfo
rInfo VerifyError
wrlItem

pprLink :: Given ColorMode => ReferenceInfo -> Maybe (Builder, Builder)
pprLink :: Given ColorMode => ReferenceInfo -> Maybe (Builder, Builder)
pprLink = \case
  RIFile ReferenceInfoFile{Maybe Text
FileLink
rifAnchor :: Maybe Text
rifLink :: FileLink
rifAnchor :: ReferenceInfoFile -> Maybe Text
rifLink :: ReferenceInfoFile -> FileLink
..} ->
    case FileLink
rifLink of
      FileLink
FLLocal -> Maybe (Builder, Builder)
forall a. Maybe a
Nothing
      FLRelative RelPosixLink
link -> (Builder, Builder) -> Maybe (Builder, Builder)
forall a. a -> Maybe a
Just (Builder
"a " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Style -> Builder -> Builder
forall a. (Pretty a, Given ColorMode) => Style -> a -> a
styleIfNeeded Style
Faint Builder
"relative" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" link", RelPosixLink -> Builder
forall p. Buildable p => p -> Builder
build RelPosixLink
link)
      FLAbsolute RelPosixLink
link -> (Builder, Builder) -> Maybe (Builder, Builder)
forall a. a -> Maybe a
Just (Builder
"an " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Style -> Builder -> Builder
forall a. (Pretty a, Given ColorMode) => Style -> a -> a
styleIfNeeded Style
Faint Builder
"absolute" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" link", RelPosixLink -> Builder
forall p. Buildable p => p -> Builder
build RelPosixLink
link)
  RIExternal (ELUrl Text
url) -> (Builder, Builder) -> Maybe (Builder, Builder)
forall a. a -> Maybe a
Just (Builder
"an " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Style -> Builder -> Builder
forall a. (Pretty a, Given ColorMode) => Style -> a -> a
styleIfNeeded Style
Faint Builder
"external" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" link", Text -> Builder
forall p. Buildable p => p -> Builder
build Text
url)
  RIExternal (ELOther Text
url) -> (Builder, Builder) -> Maybe (Builder, Builder)
forall a. a -> Maybe a
Just (Builder
"a link", Text -> Builder
forall p. Buildable p => p -> Builder
build Text
url)

pprLinkTyp :: Given ColorMode => ReferenceInfo -> Builder
pprLinkTyp :: Given ColorMode => ReferenceInfo -> Builder
pprLinkTyp ReferenceInfo
rInfo =
  Builder -> Builder
paren (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Style -> Builder -> Builder
forall a. (Pretty a, Given ColorMode) => Style -> a -> a
styleIfNeeded Style
Faint (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ case ReferenceInfo
rInfo of
    RIFile ReferenceInfoFile{FileLink
rifLink :: ReferenceInfoFile -> FileLink
rifLink :: FileLink
rifLink} ->
      case FileLink
rifLink of
        FileLink
FLLocal -> Builder
"file-local"
        FLRelative RelPosixLink
_ -> Builder
"relative"
        FLAbsolute RelPosixLink
_ -> Builder
"absolute"
    RIExternal ExternalLink
_ -> Builder
"external"

pprLinkCtx :: Given ColorMode => ReferenceInfo -> Builder
pprLinkCtx :: Given ColorMode => ReferenceInfo -> Builder
pprLinkCtx ReferenceInfo
rInfo =
  case Given ColorMode => ReferenceInfo -> Maybe (Builder, Builder)
ReferenceInfo -> Maybe (Builder, Builder)
pprLink ReferenceInfo
rInfo of
    Maybe (Builder, Builder)
Nothing -> Builder
forall a. Monoid a => a
mempty
    Just (Builder
b1, Builder
b2) -> Builder
"when processing " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Int -> Builder -> Builder
Int -> Builder -> Builder
interpolateIndentF Int
2 Builder
b2 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"

reportVerifyErrs
  :: Given ColorMode => NonEmpty (WithReferenceLoc VerifyError) -> IO ()
reportVerifyErrs :: Given ColorMode => NonEmpty (WithReferenceLoc VerifyError) -> IO ()
reportVerifyErrs NonEmpty (WithReferenceLoc VerifyError)
errs = do
  (Element (NonEmpty (WithReferenceLoc VerifyError)) -> IO ())
-> NonEmpty (WithReferenceLoc VerifyError) -> IO ()
forall t (f :: * -> *) b.
(Container t, Applicative f) =>
(Element t -> f b) -> t -> f ()
traverse_ (Builder -> IO ()
forall b. FromBuilder b => Builder -> b
fmtLn (Builder -> IO ())
-> (WithReferenceLoc VerifyError -> Builder)
-> WithReferenceLoc VerifyError
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Given ColorMode => WithReferenceLoc VerifyError -> Builder
WithReferenceLoc VerifyError -> Builder
pprVerifyErr) NonEmpty (WithReferenceLoc VerifyError)
errs
  Builder -> IO ()
forall b. FromBuilder b => Builder -> b
fmtLn (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ Color -> Builder -> Builder
forall a. (Pretty a, Given ColorMode) => Color -> a -> a
colorIfNeeded Color
Red (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$
    Builder
"Invalid references dumped, " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall p. Buildable p => p -> Builder
build (NonEmpty (WithReferenceLoc VerifyError) -> Int
forall t. Container t => t -> Int
length NonEmpty (WithReferenceLoc VerifyError)
errs) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" in total."

data RetryAfter = Date UTCTime | Seconds (Time Second)
  deriving stock (Int -> RetryAfter -> ShowS
[RetryAfter] -> ShowS
RetryAfter -> String
(Int -> RetryAfter -> ShowS)
-> (RetryAfter -> String)
-> ([RetryAfter] -> ShowS)
-> Show RetryAfter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RetryAfter -> ShowS
showsPrec :: Int -> RetryAfter -> ShowS
$cshow :: RetryAfter -> String
show :: RetryAfter -> String
$cshowList :: [RetryAfter] -> ShowS
showList :: [RetryAfter] -> ShowS
Show, RetryAfter -> RetryAfter -> Bool
(RetryAfter -> RetryAfter -> Bool)
-> (RetryAfter -> RetryAfter -> Bool) -> Eq RetryAfter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RetryAfter -> RetryAfter -> Bool
== :: RetryAfter -> RetryAfter -> Bool
$c/= :: RetryAfter -> RetryAfter -> Bool
/= :: RetryAfter -> RetryAfter -> Bool
Eq)

instance Read RetryAfter where
  readPrec :: ReadPrec RetryAfter
readPrec = [ReadPrec RetryAfter] -> ReadPrec RetryAfter
forall t (f :: * -> *) a.
(Container t, Alternative f, Element t ~ f a) =>
t -> f a
asum
    [ ReadP RetryAfter -> ReadPrec RetryAfter
forall a. ReadP a -> ReadPrec a
ReadPrec.lift (ReadP RetryAfter -> ReadPrec RetryAfter)
-> ReadP RetryAfter -> ReadPrec RetryAfter
forall a b. (a -> b) -> a -> b
$ UTCTime -> RetryAfter
Date (UTCTime -> RetryAfter) -> ReadP UTCTime -> ReadP RetryAfter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> TimeLocale -> String -> ReadP UTCTime
forall t. ParseTime t => Bool -> TimeLocale -> String -> ReadP t
readPTime Bool
True TimeLocale
defaultTimeLocale String
rfc822DateFormat
    , forall a. Read a => ReadPrec a
readPrec @Natural ReadPrec Natural -> (Natural -> RetryAfter) -> ReadPrec RetryAfter
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Time Second -> RetryAfter
Time (1 :% 1) -> RetryAfter
Seconds (Time (1 :% 1) -> RetryAfter)
-> (Natural -> Time (1 :% 1)) -> Natural -> RetryAfter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RatioNat -> Time Second
RatioNat -> Time (1 :% 1)
sec (RatioNat -> Time (1 :% 1))
-> (Natural -> RatioNat) -> Natural -> Time (1 :% 1)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral @_ @RatioNat
    ]

instance Buildable RetryAfter where
  build :: RetryAfter -> Builder
build (Date UTCTime
d) = Builder -> Builder -> Builder
nameF Builder
"date" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$
    String -> Builder
forall a. IsString a => String -> a
fromString (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
rfc822DateFormat UTCTime
d
  build (Seconds Time Second
s) = Builder -> Builder -> Builder
nameF Builder
"seconds" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Time (1 :% 1) -> Builder
forall b a. (Show a, IsString b) => a -> b
show Time Second
Time (1 :% 1)
s

data NeedsCaching key
  = NoCaching
  | CacheUnderKey key

-- | Perform concurrent traversal of the list with the caching mechanism.
-- The function is semantically similar to @Control.Concurrent.Async.forConcurrently@;
-- each asynchronous result of the @action@ is prepended to the accumulator list @[Async b]@.
-- Additionally, these action results may also be inserted in a map of the type
-- @Map cacheKey (Async b)@, depending on the return value of the function
-- @a -> NeedsCaching cacheKey@ applied to each of the element from the given list.
-- If an element of the type @a@ needs caching, and the value is already present in the map,
-- then the @action@ will not be executed, and the value is added to the accumulator list.
-- After the whole list has been traversed, the accumulator is traversed once again to ensure
-- every asynchronous action is completed.
-- If interrupted by AsyncException, returns this exception and list of already calcualted results
-- (their subset can be arbitrary). Computations that were not ended till this moment are cancelled.
forConcurrentlyCaching
  :: forall a b cacheKey.  Ord cacheKey
  => [a] -> (a -> NeedsCaching cacheKey) -> (a -> IO b) -> IO (Either (AsyncException, [b]) [b])
forConcurrentlyCaching :: forall a b cacheKey.
Ord cacheKey =>
[a]
-> (a -> NeedsCaching cacheKey)
-> (a -> IO b)
-> IO (Either (AsyncException, [b]) [b])
forConcurrentlyCaching [a]
list a -> NeedsCaching cacheKey
needsCaching a -> IO b
action = [Async b]
-> Map cacheKey (Async b)
-> [a]
-> IO (Either (AsyncException, [b]) [b])
go [] Map cacheKey (Async b)
forall k a. Map k a
M.empty [a]
list
  where
    go
      :: [Async b]
      -> Map cacheKey (Async b)
      -> [a]
      -> IO (Either (AsyncException, [b]) [b])
    go :: [Async b]
-> Map cacheKey (Async b)
-> [a]
-> IO (Either (AsyncException, [b]) [b])
go [Async b]
acc Map cacheKey (Async b)
cached [a]
items =
      case [a]
items of

        (a
x : [a]
xs) -> case a -> NeedsCaching cacheKey
needsCaching a
x of
          NeedsCaching cacheKey
NoCaching -> do
            IO b
-> (Async b -> IO (Either (AsyncException, [b]) [b]))
-> IO (Either (AsyncException, [b]) [b])
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (a -> IO b
action a
x) ((Async b -> IO (Either (AsyncException, [b]) [b]))
 -> IO (Either (AsyncException, [b]) [b]))
-> (Async b -> IO (Either (AsyncException, [b]) [b]))
-> IO (Either (AsyncException, [b]) [b])
forall a b. (a -> b) -> a -> b
$ \Async b
b ->
              [Async b]
-> Map cacheKey (Async b)
-> [a]
-> IO (Either (AsyncException, [b]) [b])
go (Async b
b Async b -> [Async b] -> [Async b]
forall a. a -> [a] -> [a]
: [Async b]
acc) Map cacheKey (Async b)
cached [a]
xs
          CacheUnderKey cacheKey
cacheKey -> do
            case cacheKey -> Map cacheKey (Async b) -> Maybe (Async b)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup cacheKey
cacheKey Map cacheKey (Async b)
cached of
              Maybe (Async b)
Nothing -> do
                IO b
-> (Async b -> IO (Either (AsyncException, [b]) [b]))
-> IO (Either (AsyncException, [b]) [b])
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (a -> IO b
action a
x) ((Async b -> IO (Either (AsyncException, [b]) [b]))
 -> IO (Either (AsyncException, [b]) [b]))
-> (Async b -> IO (Either (AsyncException, [b]) [b]))
-> IO (Either (AsyncException, [b]) [b])
forall a b. (a -> b) -> a -> b
$ \Async b
b ->
                  [Async b]
-> Map cacheKey (Async b)
-> [a]
-> IO (Either (AsyncException, [b]) [b])
go (Async b
b Async b -> [Async b] -> [Async b]
forall a. a -> [a] -> [a]
: [Async b]
acc) (cacheKey
-> Async b -> Map cacheKey (Async b) -> Map cacheKey (Async b)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert cacheKey
cacheKey Async b
b Map cacheKey (Async b)
cached) [a]
xs
              Just Async b
b -> [Async b]
-> Map cacheKey (Async b)
-> [a]
-> IO (Either (AsyncException, [b]) [b])
go (Async b
b Async b -> [Async b] -> [Async b]
forall a. a -> [a] -> [a]
: [Async b]
acc) Map cacheKey (Async b)
cached [a]
xs

        [] -> (AsyncException -> IO (Either (AsyncException, [b]) [b]))
-> IO (Either (AsyncException, [b]) [b])
-> IO (Either (AsyncException, [b]) [b])
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handleAsync
        -- Wait for all children threads to complete.
        --
        -- If, while the threads are running, the user hits Ctrl+C,
        -- a `UserInterrupt :: AsyncException` will be thrown onto the main thread.
        -- We catch it here, cancel all child threads,
        -- and return the results of only the threads that finished successfully.
          (\case
            AsyncException
UserInterrupt -> do
              [Maybe b]
partialResults <- [Async b] -> (Async b -> IO (Maybe b)) -> IO [Maybe b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Async b]
acc \Async b
asyncAction -> do
                Async b -> IO ()
forall a. Async a -> IO ()
cancel Async b
asyncAction
                Async b -> IO (Maybe (Either SomeException b))
forall a. Async a -> IO (Maybe (Either SomeException a))
poll Async b
asyncAction IO (Maybe (Either SomeException b))
-> (Maybe (Either SomeException b) -> Maybe b) -> IO (Maybe b)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                  Just (Right b
a)  -> b -> Maybe b
forall a. a -> Maybe a
Just b
a
                  Just (Left SomeException
_ex) -> Maybe b
forall a. Maybe a
Nothing
                  Maybe (Either SomeException b)
Nothing         -> Maybe b
forall a. Maybe a
Nothing
              Either (AsyncException, [b]) [b]
-> IO (Either (AsyncException, [b]) [b])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (AsyncException, [b]) [b]
 -> IO (Either (AsyncException, [b]) [b]))
-> Either (AsyncException, [b]) [b]
-> IO (Either (AsyncException, [b]) [b])
forall a b. (a -> b) -> a -> b
$ (AsyncException, [b]) -> Either (AsyncException, [b]) [b]
forall a b. a -> Either a b
Left (AsyncException
UserInterrupt, [Maybe b] -> [b]
forall a. [Maybe a] -> [a]
catMaybes [Maybe b]
partialResults)
            AsyncException
otherAsyncEx -> AsyncException -> IO (Either (AsyncException, [b]) [b])
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwM AsyncException
otherAsyncEx
          )
          (IO (Either (AsyncException, [b]) [b])
 -> IO (Either (AsyncException, [b]) [b]))
-> IO (Either (AsyncException, [b]) [b])
-> IO (Either (AsyncException, [b]) [b])
forall a b. (a -> b) -> a -> b
$ [b] -> Either (AsyncException, [b]) [b]
forall a b. b -> Either a b
Right ([b] -> Either (AsyncException, [b]) [b])
-> ([b] -> [b]) -> [b] -> Either (AsyncException, [b]) [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [b] -> [b]
forall a. [a] -> [a]
reverse ([b] -> Either (AsyncException, [b]) [b])
-> IO [b] -> IO (Either (AsyncException, [b]) [b])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Async b] -> (Async b -> IO b) -> IO [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Async b]
acc Async b -> IO b
forall a. Async a -> IO a
wait
      -- If action was already completed, then @cancel@ will have no effect, and we
      -- will get result from @cancel f >> poll f@. Otherwise action will be interrupted,
      -- so poll will return @Left (SomeException AsyncCancelled)@

verifyRepo
  :: Given ColorMode
  => Rewrite
  -> Config
  -> VerifyMode
  -> RepoInfo
  -> IO (VerifyResult $ WithReferenceLoc VerifyError)
verifyRepo :: Given ColorMode =>
Rewrite
-> Config
-> VerifyMode
-> RepoInfo
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
verifyRepo
  Rewrite
rw
  config :: Config
config@Config{Field Identity (ExclusionConfig' Identity)
Field Identity (NetworkingConfig' Identity)
ScannersConfig' Identity
cExclusions :: Field Identity (ExclusionConfig' Identity)
cNetworking :: Field Identity (NetworkingConfig' Identity)
cScanners :: ScannersConfig' Identity
cExclusions :: forall (f :: * -> *). Config' f -> Field f (ExclusionConfig' f)
cNetworking :: forall (f :: * -> *). Config' f -> Field f (NetworkingConfig' f)
cScanners :: forall (f :: * -> *). Config' f -> ScannersConfig' f
..}
  VerifyMode
mode
  repoInfo :: RepoInfo
repoInfo@RepoInfo{Map CanonicalRelPosixLink (RelPosixLink, DirectoryStatus)
Map CanonicalRelPosixLink (RelPosixLink, FileStatus)
riFiles :: Map CanonicalRelPosixLink (RelPosixLink, FileStatus)
riDirectories :: Map CanonicalRelPosixLink (RelPosixLink, DirectoryStatus)
riFiles :: RepoInfo -> Map CanonicalRelPosixLink (RelPosixLink, FileStatus)
riDirectories :: RepoInfo
-> Map CanonicalRelPosixLink (RelPosixLink, DirectoryStatus)
..}
    = do
  let toScan :: [(RelPosixLink, Reference)]
toScan = do
        (CanonicalRelPosixLink
canonicalFile, (RelPosixLink
file, FileStatus
fileInfo)) <- Map CanonicalRelPosixLink (RelPosixLink, FileStatus)
-> [(Key (Map CanonicalRelPosixLink (RelPosixLink, FileStatus)),
     Val (Map CanonicalRelPosixLink (RelPosixLink, FileStatus)))]
forall t. ToPairs t => t -> [(Key t, Val t)]
toPairs Map CanonicalRelPosixLink (RelPosixLink, FileStatus)
riFiles
        Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> (Bool -> Bool) -> Bool -> [()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ [CanonicalRelGlobPattern] -> CanonicalRelPosixLink -> Bool
matchesGlobPatterns (ExclusionConfig' Identity
-> Field Identity [CanonicalRelGlobPattern]
forall (f :: * -> *).
ExclusionConfig' f -> Field f [CanonicalRelGlobPattern]
ecIgnoreRefsFrom Field Identity (ExclusionConfig' Identity)
ExclusionConfig' Identity
cExclusions) CanonicalRelPosixLink
canonicalFile
        case FileStatus
fileInfo of
          Scanned FileInfo
fi -> do
            Reference
ref <- FileInfo -> [Reference]
_fiReferences FileInfo
fi
            (RelPosixLink, Reference) -> [(RelPosixLink, Reference)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (RelPosixLink
file, Reference
ref)
          FileStatus
NotScannable -> [(RelPosixLink, Reference)]
forall a. [a]
forall (f :: * -> *) a. Alternative f => f a
empty -- No support for such file, can do nothing.
          FileStatus
NotAddedToGit -> [(RelPosixLink, Reference)]
forall a. [a]
forall (f :: * -> *) a. Alternative f => f a
empty -- If this file is scannable, we've notified
                                 -- user that we are scanning only files
                                 -- added to Git while gathering RepoInfo.

  IORef VerifyProgress
progressRef <- VerifyProgress -> IO (IORef VerifyProgress)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (VerifyProgress -> IO (IORef VerifyProgress))
-> VerifyProgress -> IO (IORef VerifyProgress)
forall a b. (a -> b) -> a -> b
$ [Reference] -> VerifyProgress
initVerifyProgress (((RelPosixLink, Reference) -> Reference)
-> [(RelPosixLink, Reference)] -> [Reference]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (RelPosixLink, Reference) -> Reference
forall a b. (a, b) -> b
snd [(RelPosixLink, Reference)]
toScan)
  IORef (Set DomainName)
domainsReturned429Ref <- Set DomainName -> IO (IORef (Set DomainName))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Set DomainName
forall a. Set a
S.empty
  Either
  (AsyncException, [VerifyResult $ WithReferenceLoc VerifyError])
  [VerifyResult $ WithReferenceLoc VerifyError]
accumulated <- IO ()
-> IO
     (Either
        (AsyncException, [VerifyResult $ WithReferenceLoc VerifyError])
        [VerifyResult $ WithReferenceLoc VerifyError])
-> IO
     (Either
        (AsyncException, [VerifyResult $ WithReferenceLoc VerifyError])
        [VerifyResult $ WithReferenceLoc VerifyError])
forall a b. IO a -> IO b -> IO b
loopAsyncUntil (IORef VerifyProgress -> IO ()
printer IORef VerifyProgress
progressRef) do
    [(RelPosixLink, Reference)]
-> ((RelPosixLink, Reference) -> NeedsCaching Text)
-> ((RelPosixLink, Reference)
    -> IO (VerifyResult $ WithReferenceLoc VerifyError))
-> IO
     (Either
        (AsyncException, [VerifyResult $ WithReferenceLoc VerifyError])
        [VerifyResult $ WithReferenceLoc VerifyError])
forall a b cacheKey.
Ord cacheKey =>
[a]
-> (a -> NeedsCaching cacheKey)
-> (a -> IO b)
-> IO (Either (AsyncException, [b]) [b])
forConcurrentlyCaching [(RelPosixLink, Reference)]
toScan (RelPosixLink, Reference) -> NeedsCaching Text
forall a. (a, Reference) -> NeedsCaching Text
ifExternalThenCache (((RelPosixLink, Reference)
  -> IO (VerifyResult $ WithReferenceLoc VerifyError))
 -> IO
      (Either
         (AsyncException, [VerifyResult $ WithReferenceLoc VerifyError])
         [VerifyResult $ WithReferenceLoc VerifyError]))
-> ((RelPosixLink, Reference)
    -> IO (VerifyResult $ WithReferenceLoc VerifyError))
-> IO
     (Either
        (AsyncException, [VerifyResult $ WithReferenceLoc VerifyError])
        [VerifyResult $ WithReferenceLoc VerifyError])
forall a b. (a -> b) -> a -> b
$ \(RelPosixLink
file, Reference
ref) ->
      Config
-> VerifyMode
-> IORef (Set DomainName)
-> IORef VerifyProgress
-> RepoInfo
-> RelPosixLink
-> Reference
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
verifyReference Config
config VerifyMode
mode IORef (Set DomainName)
domainsReturned429Ref IORef VerifyProgress
progressRef RepoInfo
repoInfo RelPosixLink
file Reference
ref
  case Either
  (AsyncException, [VerifyResult $ WithReferenceLoc VerifyError])
  [VerifyResult $ WithReferenceLoc VerifyError]
accumulated of
    Right [VerifyResult $ WithReferenceLoc VerifyError]
res -> (VerifyResult $ WithReferenceLoc VerifyError)
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((VerifyResult $ WithReferenceLoc VerifyError)
 -> IO (VerifyResult $ WithReferenceLoc VerifyError))
-> (VerifyResult $ WithReferenceLoc VerifyError)
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
forall a b. (a -> b) -> a -> b
$ [VerifyResult $ WithReferenceLoc VerifyError]
-> Element [VerifyResult $ WithReferenceLoc VerifyError]
forall t. (Container t, Monoid (Element t)) => t -> Element t
fold [VerifyResult $ WithReferenceLoc VerifyError]
res
    Left (AsyncException
exception, [VerifyResult $ WithReferenceLoc VerifyError]
partialRes) -> do
      -- The user has hit Ctrl+C; display any verification errors we managed to find and exit.
      let errs :: Maybe (NonEmpty (WithReferenceLoc VerifyError))
errs = (VerifyResult $ WithReferenceLoc VerifyError)
-> Maybe (NonEmpty (WithReferenceLoc VerifyError))
forall e. VerifyResult e -> Maybe (NonEmpty e)
verifyErrors ([VerifyResult $ WithReferenceLoc VerifyError]
-> Element [VerifyResult $ WithReferenceLoc VerifyError]
forall t. (Container t, Monoid (Element t)) => t -> Element t
fold [VerifyResult $ WithReferenceLoc VerifyError]
partialRes)
          total :: Int
total = [(RelPosixLink, Reference)] -> Int
forall t. Container t => t -> Int
length [(RelPosixLink, Reference)]
toScan
          checked :: Int
checked = [VerifyResult $ WithReferenceLoc VerifyError] -> Int
forall t. Container t => t -> Int
length [VerifyResult $ WithReferenceLoc VerifyError]
partialRes
      Maybe (NonEmpty (WithReferenceLoc VerifyError))
-> (NonEmpty (WithReferenceLoc VerifyError) -> IO ()) -> IO ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe (NonEmpty (WithReferenceLoc VerifyError))
errs NonEmpty (WithReferenceLoc VerifyError) -> IO ()
Given ColorMode => NonEmpty (WithReferenceLoc VerifyError) -> IO ()
reportVerifyErrs
      Builder -> IO ()
forall b. FromBuilder b => Builder -> b
fmt [int|A|
          Interrupted (#s{exception}), checked #{checked} out of #{total} references.
          |]
      IO (VerifyResult $ WithReferenceLoc VerifyError)
forall (m :: * -> *) a. MonadIO m => m a
exitFailure

  where
    printer :: IORef VerifyProgress -> IO ()
    printer :: IORef VerifyProgress -> IO ()
printer IORef VerifyProgress
progressRef = do
      Time (1 :% 1)
posixTime <- IO POSIXTime
getPOSIXTime IO POSIXTime -> (POSIXTime -> Time (1 :% 1)) -> IO (Time (1 :% 1))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> POSIXTime -> Time Second
POSIXTime -> Time (1 :% 1)
posixTimeToTimeSecond
      VerifyProgress
progress <- IORef VerifyProgress
-> (VerifyProgress -> (VerifyProgress, VerifyProgress))
-> IO VerifyProgress
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef VerifyProgress
progressRef ((VerifyProgress -> (VerifyProgress, VerifyProgress))
 -> IO VerifyProgress)
-> (VerifyProgress -> (VerifyProgress, VerifyProgress))
-> IO VerifyProgress
forall a b. (a -> b) -> a -> b
$ \VerifyProgress{Progress Int ()
Progress Int Text
vrLocal :: Progress Int ()
vrExternal :: Progress Int Text
vrLocal :: VerifyProgress -> Progress Int ()
vrExternal :: VerifyProgress -> Progress Int Text
..} ->
        let prog :: VerifyProgress
prog = VerifyProgress{ vrExternal :: Progress Int Text
vrExternal =
          Time Second -> Progress Int Text -> Progress Int Text
forall a w. Time Second -> Progress a w -> Progress a w
checkTaskTimestamp Time Second
Time (1 :% 1)
posixTime Progress Int Text
vrExternal
                                 , Progress Int ()
vrLocal :: Progress Int ()
vrLocal :: Progress Int ()
..
                                 }
        in (VerifyProgress
prog, VerifyProgress
prog)
      Given ColorMode =>
Rewrite -> VerifyMode -> Time Second -> VerifyProgress -> IO ()
Rewrite -> VerifyMode -> Time Second -> VerifyProgress -> IO ()
reprintAnalyseProgress Rewrite
rw VerifyMode
mode Time Second
Time (1 :% 1)
posixTime VerifyProgress
progress
      -- Slight pause so we're not refreshing the progress bar more often than needed.
      Time (1 :% 1000) -> IO ()
forall (unit :: Rat) (m :: * -> *).
(KnownDivRat unit Microsecond, MonadIO m) =>
Time unit -> m ()
threadDelay (RatioNat -> Time Millisecond
ms RatioNat
100)

    ifExternalThenCache :: (a, Reference) -> NeedsCaching Text
    ifExternalThenCache :: forall a. (a, Reference) -> NeedsCaching Text
ifExternalThenCache (a
_, Reference{Text
ReferenceInfo
Position
rName :: Reference -> Text
rInfo :: Reference -> ReferenceInfo
rPos :: Reference -> Position
rName :: Text
rPos :: Position
rInfo :: ReferenceInfo
..}) =
      case ReferenceInfo
rInfo of
        RIExternal (ELUrl Text
url) ->
          Text -> NeedsCaching Text
forall key. key -> NeedsCaching key
CacheUnderKey Text
url
        ReferenceInfo
_ ->
          NeedsCaching Text
forall key. NeedsCaching key
NoCaching

shouldCheckLocType :: VerifyMode -> ReferenceInfo -> Bool
shouldCheckLocType :: VerifyMode -> ReferenceInfo -> Bool
shouldCheckLocType VerifyMode
mode ReferenceInfo
rInfo =
  case ReferenceInfo
rInfo of
    RIFile ReferenceInfoFile
_ -> VerifyMode -> Bool
shouldCheckLocal VerifyMode
mode
    RIExternal (ELUrl Text
_) -> VerifyMode -> Bool
shouldCheckExternal VerifyMode
mode
    RIExternal (ELOther Text
_) -> Bool
False

verifyReference
  :: Config
  -> VerifyMode
  -> IORef (S.Set DomainName)
  -> IORef VerifyProgress
  -> RepoInfo
  -> RelPosixLink
  -> Reference
  -> IO (VerifyResult $ WithReferenceLoc VerifyError)
verifyReference :: Config
-> VerifyMode
-> IORef (Set DomainName)
-> IORef VerifyProgress
-> RepoInfo
-> RelPosixLink
-> Reference
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
verifyReference
  config :: Config
config@Config{Field Identity (ExclusionConfig' Identity)
Field Identity (NetworkingConfig' Identity)
ScannersConfig' Identity
cExclusions :: forall (f :: * -> *). Config' f -> Field f (ExclusionConfig' f)
cNetworking :: forall (f :: * -> *). Config' f -> Field f (NetworkingConfig' f)
cScanners :: forall (f :: * -> *). Config' f -> ScannersConfig' f
cExclusions :: Field Identity (ExclusionConfig' Identity)
cNetworking :: Field Identity (NetworkingConfig' Identity)
cScanners :: ScannersConfig' Identity
..}
  VerifyMode
mode
  IORef (Set DomainName)
domainsReturned429Ref
  IORef VerifyProgress
progressRef
  RepoInfo
repoInfo
  RelPosixLink
file
  ref :: Reference
ref@Reference{Text
ReferenceInfo
Position
rName :: Reference -> Text
rInfo :: Reference -> ReferenceInfo
rPos :: Reference -> Position
rName :: Text
rPos :: Position
rInfo :: ReferenceInfo
..}
    = (Either VerifyError ()
 -> VerifyResult $ WithReferenceLoc VerifyError)
-> IO (Either VerifyError ())
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((VerifyError -> WithReferenceLoc VerifyError)
-> VerifyResult VerifyError
-> VerifyResult $ WithReferenceLoc VerifyError
forall a b. (a -> b) -> VerifyResult a -> VerifyResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VerifyError -> WithReferenceLoc VerifyError
addReference (VerifyResult VerifyError
 -> VerifyResult $ WithReferenceLoc VerifyError)
-> (Either VerifyError () -> VerifyResult VerifyError)
-> Either VerifyError ()
-> VerifyResult $ WithReferenceLoc VerifyError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either VerifyError () -> VerifyResult VerifyError
forall e. Either e () -> VerifyResult e
toVerifyRes) (IO (Either VerifyError ())
 -> IO (VerifyResult $ WithReferenceLoc VerifyError))
-> IO (Either VerifyError ())
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
forall a b. (a -> b) -> a -> b
$
      RetryCounter
-> IO (Either VerifyError ()) -> IO (Either VerifyError ())
retryVerification (Int -> Int -> RetryCounter
RetryCounter Int
0 Int
0) (IO (Either VerifyError ()) -> IO (Either VerifyError ()))
-> IO (Either VerifyError ()) -> IO (Either VerifyError ())
forall a b. (a -> b) -> a -> b
$ ExceptT VerifyError IO () -> IO (Either VerifyError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT VerifyError IO () -> IO (Either VerifyError ()))
-> ExceptT VerifyError IO () -> IO (Either VerifyError ())
forall a b. (a -> b) -> a -> b
$
        if VerifyMode -> ReferenceInfo -> Bool
shouldCheckLocType VerifyMode
mode ReferenceInfo
rInfo
        then case ReferenceInfo
rInfo of
          RIFile ReferenceInfoFile{Maybe Text
FileLink
rifAnchor :: ReferenceInfoFile -> Maybe Text
rifLink :: ReferenceInfoFile -> FileLink
rifAnchor :: Maybe Text
rifLink :: FileLink
..} ->
            case FileLink
rifLink of
              FileLink
FLLocal ->
                Maybe Text -> RelPosixLink -> ExceptT VerifyError IO ()
checkRef Maybe Text
rifAnchor RelPosixLink
file
              FLRelative RelPosixLink
link ->
                Maybe Text -> RelPosixLink -> ExceptT VerifyError IO ()
checkRef Maybe Text
rifAnchor (RelPosixLink -> ExceptT VerifyError IO ())
-> RelPosixLink -> ExceptT VerifyError IO ()
forall a b. (a -> b) -> a -> b
$ RelPosixLink -> RelPosixLink
takeDirectory RelPosixLink
file RelPosixLink -> RelPosixLink -> RelPosixLink
</> RelPosixLink
link
              FLAbsolute RelPosixLink
link ->
                Maybe Text -> RelPosixLink -> ExceptT VerifyError IO ()
checkRef Maybe Text
rifAnchor RelPosixLink
link
          RIExternal (ELUrl Text
url) ->
            RedirectChain -> Config -> Text -> ExceptT VerifyError IO ()
checkExternalResource RedirectChain
emptyChain Config
config Text
url
          RIExternal (ELOther Text
_) ->
            ExceptT VerifyError IO ()
forall (f :: * -> *). Applicative f => f ()
pass
        else ExceptT VerifyError IO ()
forall (f :: * -> *). Applicative f => f ()
pass
  where
    addReference :: VerifyError -> WithReferenceLoc VerifyError
    addReference :: VerifyError -> WithReferenceLoc VerifyError
addReference = RelPosixLink
-> Reference -> VerifyError -> WithReferenceLoc VerifyError
forall a. RelPosixLink -> Reference -> a -> WithReferenceLoc a
WithReferenceLoc RelPosixLink
file Reference
ref

    retryVerification
      :: RetryCounter
      -> IO (Either VerifyError ())
      -> IO (Either VerifyError ())
    retryVerification :: RetryCounter
-> IO (Either VerifyError ()) -> IO (Either VerifyError ())
retryVerification RetryCounter
rc IO (Either VerifyError ())
resIO = do
      Either VerifyError ()
res <- IO (Either VerifyError ())
resIO
      case Either VerifyError ()
res of
        -- Success
        Right () -> Maybe (Time Second, Time Second)
-> (forall w. Ord w => w -> Progress Int w -> Progress Int w)
-> IO ()
modifyProgressRef Maybe (Time Second, Time Second)
Maybe (Time (1 :% 1), Time (1 :% 1))
forall a. Maybe a
Nothing w -> Progress Int w -> Progress Int w
forall w. Ord w => w -> Progress Int w -> Progress Int w
forall a w. (Num a, Ord w) => w -> Progress a w -> Progress a w
reportSuccess IO () -> Either VerifyError () -> IO (Either VerifyError ())
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Either VerifyError ()
res
        Left VerifyError
err -> do
          Set DomainName
setOfReturned429 <- IORef (Set DomainName) -> VerifyError -> IO (Set DomainName)
addDomainIf429 IORef (Set DomainName)
domainsReturned429Ref VerifyError
err
          case Set DomainName
-> RetryCounter
-> VerifyError
-> Maybe (Maybe RetryAfter, RetryCounter -> RetryCounter)
decideWhetherToRetry Set DomainName
setOfReturned429 RetryCounter
rc VerifyError
err of
            -- Unfixable
            Maybe (Maybe RetryAfter, RetryCounter -> RetryCounter)
Nothing -> Maybe (Time Second, Time Second)
-> (forall w. Ord w => w -> Progress Int w -> Progress Int w)
-> IO ()
modifyProgressRef Maybe (Time Second, Time Second)
Maybe (Time (1 :% 1), Time (1 :% 1))
forall a. Maybe a
Nothing w -> Progress Int w -> Progress Int w
forall w. Ord w => w -> Progress Int w -> Progress Int w
forall a w. (Num a, Ord w) => w -> Progress a w -> Progress a w
reportError IO () -> Either VerifyError () -> IO (Either VerifyError ())
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Either VerifyError ()
res
            -- Fixable, retry
            Just (Maybe RetryAfter
mbCurrentRetryAfter, RetryCounter -> RetryCounter
counterModifier) -> do
              Time (1 :% 1)
now <- IO POSIXTime
getPOSIXTime IO POSIXTime -> (POSIXTime -> Time (1 :% 1)) -> IO (Time (1 :% 1))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> POSIXTime -> Time Second
POSIXTime -> Time (1 :% 1)
posixTimeToTimeSecond

              let toSeconds :: RetryAfter -> Time Second
toSeconds = \case
                    Seconds Time Second
s -> Time Second
s
                    -- Calculates the seconds left until @Retry-After@ date.
                    -- Defaults to 0 if the date has already passed.
                    Date UTCTime
date | UTCTime -> Time Second
utcTimeToTimeSecond UTCTime
date Time (1 :% 1) -> Time (1 :% 1) -> Bool
forall a. Ord a => a -> a -> Bool
>= Time (1 :% 1)
now -> UTCTime -> Time Second
utcTimeToTimeSecond UTCTime
date Time (1 :% 1) -> Time (1 :% 1) -> Time (1 :% 1)
forall (unitResult :: Rat) (unitLeft :: Rat).
KnownDivRat unitLeft unitResult =>
Time unitLeft -> Time unitResult -> Time unitResult
-:- Time (1 :% 1)
now
                    RetryAfter
_ -> RatioNat -> Time Second
sec RatioNat
0

              let currentRetryAfter :: Time (1 :% 1)
currentRetryAfter = Time (1 :% 1) -> Maybe (Time (1 :% 1)) -> Time (1 :% 1)
forall a. a -> Maybe a -> a
fromMaybe (NetworkingConfig' Identity -> Field Identity (Time Second)
forall (f :: * -> *). NetworkingConfig' f -> Field f (Time Second)
ncDefaultRetryAfter Field Identity (NetworkingConfig' Identity)
NetworkingConfig' Identity
cNetworking) (Maybe (Time (1 :% 1)) -> Time (1 :% 1))
-> Maybe (Time (1 :% 1)) -> Time (1 :% 1)
forall a b. (a -> b) -> a -> b
$
                    (RetryAfter -> Time (1 :% 1))
-> Maybe RetryAfter -> Maybe (Time (1 :% 1))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RetryAfter -> Time Second
RetryAfter -> Time (1 :% 1)
toSeconds Maybe RetryAfter
mbCurrentRetryAfter

              Maybe (Time Second, Time Second)
-> (forall w. Ord w => w -> Progress Int w -> Progress Int w)
-> IO ()
modifyProgressRef ((Time (1 :% 1), Time (1 :% 1))
-> Maybe (Time (1 :% 1), Time (1 :% 1))
forall a. a -> Maybe a
Just (Time (1 :% 1)
now, Time (1 :% 1)
currentRetryAfter)) w -> Progress Int w -> Progress Int w
forall w. Ord w => w -> Progress Int w -> Progress Int w
forall w a. Ord w => w -> Progress a w -> Progress a w
reportRetry
              Time (1 :% 1) -> IO ()
forall (unit :: Rat) (m :: * -> *).
(KnownDivRat unit Microsecond, MonadIO m) =>
Time unit -> m ()
threadDelay Time (1 :% 1)
currentRetryAfter
              RetryCounter
-> IO (Either VerifyError ()) -> IO (Either VerifyError ())
retryVerification (RetryCounter -> RetryCounter
counterModifier RetryCounter
rc) IO (Either VerifyError ())
resIO

    modifyProgressRef
      :: Maybe (Time Second, Time Second)
      -> (forall w. Ord w => w -> Progress Int w -> Progress Int w)
      -> IO ()
    modifyProgressRef :: Maybe (Time Second, Time Second)
-> (forall w. Ord w => w -> Progress Int w -> Progress Int w)
-> IO ()
modifyProgressRef Maybe (Time Second, Time Second)
mbRetryData forall w. Ord w => w -> Progress Int w -> Progress Int w
moveProgress = IORef VerifyProgress
-> (VerifyProgress -> (VerifyProgress, ())) -> IO ()
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef VerifyProgress
progressRef ((VerifyProgress -> (VerifyProgress, ())) -> IO ())
-> (VerifyProgress -> (VerifyProgress, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \VerifyProgress{Progress Int ()
Progress Int Text
vrLocal :: VerifyProgress -> Progress Int ()
vrExternal :: VerifyProgress -> Progress Int Text
vrLocal :: Progress Int ()
vrExternal :: Progress Int Text
..} ->
      ( case ReferenceInfo
rInfo of
          RIFile ReferenceInfoFile
_ -> VerifyProgress{ vrLocal :: Progress Int ()
vrLocal = () -> Progress Int () -> Progress Int ()
forall w. Ord w => w -> Progress Int w -> Progress Int w
moveProgress () Progress Int ()
vrLocal, Progress Int Text
vrExternal :: Progress Int Text
vrExternal :: Progress Int Text
.. }
          RIExternal (ELOther Text
_) -> VerifyProgress{ vrLocal :: Progress Int ()
vrLocal = () -> Progress Int () -> Progress Int ()
forall w. Ord w => w -> Progress Int w -> Progress Int w
moveProgress () Progress Int ()
vrLocal, Progress Int Text
vrExternal :: Progress Int Text
vrExternal :: Progress Int Text
.. }
          RIExternal (ELUrl Text
url) -> VerifyProgress{ vrExternal :: Progress Int Text
vrExternal =
            let vrExternalAdvanced :: Progress Int Text
vrExternalAdvanced = Text -> Progress Int Text -> Progress Int Text
forall w. Ord w => w -> Progress Int w -> Progress Int w
moveProgress Text
url Progress Int Text
vrExternal
            in  case Maybe (Time Second, Time Second)
mbRetryData of
                  Just (Time Second
now, Time Second
retryAfter) -> case Progress Int Text -> Maybe TaskTimestamp
forall a w. Progress a w -> Maybe TaskTimestamp
getTaskTimestamp Progress Int Text
vrExternal of
                    Just (TaskTimestamp Time Second
ttc Time Second
start)
                      | Time Second
Time (1 :% 1)
retryAfter Time (1 :% 1) -> Time (1 :% 1) -> Time (1 :% 1)
forall (unitResult :: Rat) (unitLeft :: Rat).
KnownDivRat unitLeft unitResult =>
Time unitLeft -> Time unitResult -> Time unitResult
+:+ Time Second
Time (1 :% 1)
now Time (1 :% 1) -> Time (1 :% 1) -> Bool
forall a. Ord a => a -> a -> Bool
<= Time Second
Time (1 :% 1)
ttc Time (1 :% 1) -> Time (1 :% 1) -> Time (1 :% 1)
forall (unitResult :: Rat) (unitLeft :: Rat).
KnownDivRat unitLeft unitResult =>
Time unitLeft -> Time unitResult -> Time unitResult
+:+ Time Second
Time (1 :% 1)
start -> Progress Int Text
vrExternalAdvanced
                    Maybe TaskTimestamp
_ -> Text
-> Time Second
-> Time Second
-> Progress Int Text
-> Progress Int Text
forall w a.
w -> Time Second -> Time Second -> Progress a w -> Progress a w
setTaskTimestamp Text
url Time Second
retryAfter Time Second
now Progress Int Text
vrExternalAdvanced
                  Maybe (Time Second, Time Second)
Nothing -> Progress Int Text
vrExternalAdvanced, Progress Int ()
vrLocal :: Progress Int ()
vrLocal :: Progress Int ()
.. }
      , ()
      )

    addDomainIf429 :: IORef (S.Set DomainName) -> VerifyError -> IO (S.Set DomainName)
    addDomainIf429 :: IORef (Set DomainName) -> VerifyError -> IO (Set DomainName)
addDomainIf429 IORef (Set DomainName)
setRef VerifyError
err = IORef (Set DomainName)
-> (Set DomainName -> (Set DomainName, Set DomainName))
-> IO (Set DomainName)
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef (Set DomainName)
setRef ((Set DomainName -> (Set DomainName, Set DomainName))
 -> IO (Set DomainName))
-> (Set DomainName -> (Set DomainName, Set DomainName))
-> IO (Set DomainName)
forall a b. (a -> b) -> a -> b
$ \Set DomainName
s ->
      (\Set DomainName
x -> (Set DomainName
x, Set DomainName
x)) (Set DomainName -> (Set DomainName, Set DomainName))
-> Set DomainName -> (Set DomainName, Set DomainName)
forall a b. (a -> b) -> a -> b
$ case VerifyError
err of
      ExternalHttpTooManyRequests Maybe RetryAfter
_ Maybe DomainName
mbDomain ->
        Set DomainName
-> (DomainName -> Set DomainName)
-> Maybe DomainName
-> Set DomainName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set DomainName
s ((DomainName -> Set DomainName -> Set DomainName)
-> Set DomainName -> DomainName -> Set DomainName
forall a b c. (a -> b -> c) -> b -> a -> c
flip DomainName -> Set DomainName -> Set DomainName
forall a. Ord a => a -> Set a -> Set a
S.insert Set DomainName
s) Maybe DomainName
mbDomain
      VerifyError
_ -> Set DomainName
s

    decideWhetherToRetry
      :: S.Set DomainName
      -> RetryCounter
      -> VerifyError
      -> Maybe (Maybe RetryAfter, RetryCounter -> RetryCounter)
    decideWhetherToRetry :: Set DomainName
-> RetryCounter
-> VerifyError
-> Maybe (Maybe RetryAfter, RetryCounter -> RetryCounter)
decideWhetherToRetry Set DomainName
setOfReturned429 RetryCounter
rc = \case
      ExternalHttpTooManyRequests Maybe RetryAfter
retryAfter Maybe DomainName
_
        | Bool
totalRetriesNotExceeded -> (Maybe RetryAfter, RetryCounter -> RetryCounter)
-> Maybe (Maybe RetryAfter, RetryCounter -> RetryCounter)
forall a. a -> Maybe a
Just (Maybe RetryAfter
retryAfter, RetryCounter -> RetryCounter
incTotalCounter)
      ExternalHttpTimeout (Just DomainName
domain)
        | Bool
totalRetriesNotExceeded Bool -> Bool -> Bool
&& Bool
timeoutRetriesNotExceeded ->
          -- If a given domain ever returned 429 error, we assume that getting timeout from
          -- the domain can be considered as a 429-like error, and hence we retry.
          -- If there was no 429 responses from this domain, then getting timeout from
          -- it probably means that this site is not working at all.
          -- Also, there always remains a possibility that we just didn't get the response
          -- in time, but we can't avoid this case here, the only thing that can help
          -- is to increase the allowed timeout in the config.

          if DomainName -> Set DomainName -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member DomainName
domain Set DomainName
setOfReturned429
          then (Maybe RetryAfter, RetryCounter -> RetryCounter)
-> Maybe (Maybe RetryAfter, RetryCounter -> RetryCounter)
forall a. a -> Maybe a
Just (RetryAfter -> Maybe RetryAfter
forall a. a -> Maybe a
Just (Time Second -> RetryAfter
Seconds (Time Second -> RetryAfter) -> Time Second -> RetryAfter
forall a b. (a -> b) -> a -> b
$ RatioNat -> Time Second
sec RatioNat
0), RetryCounter -> RetryCounter
incTimeoutCounter (RetryCounter -> RetryCounter)
-> (RetryCounter -> RetryCounter) -> RetryCounter -> RetryCounter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RetryCounter -> RetryCounter
incTotalCounter)
          else Maybe (Maybe RetryAfter, RetryCounter -> RetryCounter)
forall a. Maybe a
Nothing
      VerifyError
_ -> Maybe (Maybe RetryAfter, RetryCounter -> RetryCounter)
forall a. Maybe a
Nothing
      where
        totalRetriesNotExceeded :: Bool
totalRetriesNotExceeded = RetryCounter -> Int
rcTotalRetries RetryCounter
rc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< NetworkingConfig' Identity -> Field Identity Int
forall (f :: * -> *). NetworkingConfig' f -> Field f Int
ncMaxRetries Field Identity (NetworkingConfig' Identity)
NetworkingConfig' Identity
cNetworking
        timeoutRetriesNotExceeded :: Bool
timeoutRetriesNotExceeded = RetryCounter -> Int
rcTimeoutRetries RetryCounter
rc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< NetworkingConfig' Identity -> Field Identity Int
forall (f :: * -> *). NetworkingConfig' f -> Field f Int
ncMaxTimeoutRetries Field Identity (NetworkingConfig' Identity)
NetworkingConfig' Identity
cNetworking

    isVirtual :: CanonicalRelPosixLink -> Bool
isVirtual = [CanonicalRelGlobPattern] -> CanonicalRelPosixLink -> Bool
matchesGlobPatterns (ExclusionConfig' Identity
-> Field Identity [CanonicalRelGlobPattern]
forall (f :: * -> *).
ExclusionConfig' f -> Field f [CanonicalRelGlobPattern]
ecIgnoreLocalRefsTo Field Identity (ExclusionConfig' Identity)
ExclusionConfig' Identity
cExclusions)

    -- Checks a local file reference.
    checkRef :: Maybe Text -> RelPosixLink -> ExceptT VerifyError IO ()
    checkRef :: Maybe Text -> RelPosixLink -> ExceptT VerifyError IO ()
checkRef Maybe Text
mAnchor RelPosixLink
referredFile = do
      let canonicalFile :: CanonicalRelPosixLink
canonicalFile = RelPosixLink -> CanonicalRelPosixLink
canonicalizeRelPosixLink RelPosixLink
referredFile
      Bool -> ExceptT VerifyError IO () -> ExceptT VerifyError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CanonicalRelPosixLink -> Bool
isVirtual CanonicalRelPosixLink
canonicalFile) do
        Bool -> ExceptT VerifyError IO () -> ExceptT VerifyError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CanonicalRelPosixLink -> Bool
hasUnexpanededParentIndirections CanonicalRelPosixLink
canonicalFile) (ExceptT VerifyError IO () -> ExceptT VerifyError IO ())
-> ExceptT VerifyError IO () -> ExceptT VerifyError IO ()
forall a b. (a -> b) -> a -> b
$
          VerifyError -> ExceptT VerifyError IO ()
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError -> ExceptT VerifyError IO ())
-> VerifyError -> ExceptT VerifyError IO ()
forall a b. (a -> b) -> a -> b
$ RelPosixLink -> VerifyError
LocalFileOutsideRepo RelPosixLink
referredFile

        Either DirectoryStatus FileStatus
mFileStatus <- RelPosixLink
-> ExceptT VerifyError IO (Either DirectoryStatus FileStatus)
tryGetFileStatus RelPosixLink
referredFile
        case Either DirectoryStatus FileStatus
mFileStatus of
          Right (Scanned FileInfo
referredFileInfo) -> Maybe Text
-> (Text -> ExceptT VerifyError IO ()) -> ExceptT VerifyError IO ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe Text
mAnchor ((Text -> ExceptT VerifyError IO ()) -> ExceptT VerifyError IO ())
-> (Text -> ExceptT VerifyError IO ()) -> ExceptT VerifyError IO ()
forall a b. (a -> b) -> a -> b
$
            RelPosixLink -> [Anchor] -> Text -> ExceptT VerifyError IO ()
checkAnchor RelPosixLink
referredFile (FileInfo -> [Anchor]
_fiAnchors FileInfo
referredFileInfo)
          Right FileStatus
NotAddedToGit -> VerifyError -> ExceptT VerifyError IO ()
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RelPosixLink -> VerifyError
LinkTargetNotAddedToGit RelPosixLink
referredFile)
          Left DirectoryStatus
UntrackedDirectory -> VerifyError -> ExceptT VerifyError IO ()
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RelPosixLink -> VerifyError
LinkTargetNotAddedToGit RelPosixLink
referredFile)
          Right FileStatus
NotScannable -> ExceptT VerifyError IO ()
forall (f :: * -> *). Applicative f => f ()
pass -- no support for such file, can do nothing
          Left DirectoryStatus
TrackedDirectory -> ExceptT VerifyError IO ()
forall (f :: * -> *). Applicative f => f ()
pass -- path leads to directory, currently
                                        -- if such link contain anchor, we ignore it

    caseInsensitive :: Bool
caseInsensitive = Flavor -> Bool
caseInsensitiveAnchors (Flavor -> Bool)
-> (ScannersConfig' Identity -> Flavor)
-> ScannersConfig' Identity
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MarkdownConfig -> Flavor
mcFlavor (MarkdownConfig -> Flavor)
-> (ScannersConfig' Identity -> MarkdownConfig)
-> ScannersConfig' Identity
-> Flavor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScannersConfig' Identity -> MarkdownConfig
forall (f :: * -> *). ScannersConfig' f -> MarkdownConfig
scMarkdown (ScannersConfig' Identity -> Bool)
-> ScannersConfig' Identity -> Bool
forall a b. (a -> b) -> a -> b
$ ScannersConfig' Identity
cScanners

    -- Returns `Nothing` when path corresponds to an existing (and tracked) directory
    tryGetFileStatus :: RelPosixLink -> ExceptT VerifyError IO (Either DirectoryStatus FileStatus)
    tryGetFileStatus :: RelPosixLink
-> ExceptT VerifyError IO (Either DirectoryStatus FileStatus)
tryGetFileStatus RelPosixLink
filePath
      | Just FileStatus
f <- CanonicalRelPosixLink -> RepoInfo -> Maybe FileStatus
lookupFile CanonicalRelPosixLink
canonicalFile RepoInfo
repoInfo = Either DirectoryStatus FileStatus
-> ExceptT VerifyError IO (Either DirectoryStatus FileStatus)
forall a. a -> ExceptT VerifyError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileStatus -> Either DirectoryStatus FileStatus
forall a b. b -> Either a b
Right FileStatus
f)
      | Just DirectoryStatus
d <- CanonicalRelPosixLink -> RepoInfo -> Maybe DirectoryStatus
lookupDirectory CanonicalRelPosixLink
canonicalFile RepoInfo
repoInfo = Either DirectoryStatus FileStatus
-> ExceptT VerifyError IO (Either DirectoryStatus FileStatus)
forall a. a -> ExceptT VerifyError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DirectoryStatus -> Either DirectoryStatus FileStatus
forall a b. a -> Either a b
Left DirectoryStatus
d)
      | Bool
otherwise = VerifyError
-> ExceptT VerifyError IO (Either DirectoryStatus FileStatus)
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RelPosixLink -> VerifyError
LocalFileDoesNotExist RelPosixLink
filePath)
      where
        canonicalFile :: CanonicalRelPosixLink
canonicalFile = RelPosixLink -> CanonicalRelPosixLink
canonicalizeRelPosixLink RelPosixLink
filePath

    checkAnchor :: RelPosixLink -> [Anchor] -> Text -> ExceptT VerifyError IO ()
checkAnchor RelPosixLink
filePath [Anchor]
fileAnchors Text
anchor = do
      RelPosixLink -> [Anchor] -> Text -> ExceptT VerifyError IO ()
checkAnchorReferenceAmbiguity RelPosixLink
filePath [Anchor]
fileAnchors Text
anchor
      RelPosixLink -> [Anchor] -> Text -> ExceptT VerifyError IO ()
checkDeduplicatedAnchorReference RelPosixLink
filePath [Anchor]
fileAnchors Text
anchor
      [Anchor] -> Text -> ExceptT VerifyError IO ()
checkAnchorExists [Anchor]
fileAnchors Text
anchor

    anchorNameEq :: Text -> Text -> Bool
anchorNameEq =
      if Bool
caseInsensitive
      then Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Text -> Text -> Bool) -> (Text -> Text) -> Text -> Text -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Text -> Text
toCaseFold
      else Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==)

    -- Detect a case when original file contains two identical anchors, github
    -- has added a suffix to the duplicate, and now the original is referrenced -
    -- such links are pretty fragile and we discourage their use despite
    -- they are in fact unambiguous.
    checkAnchorReferenceAmbiguity :: RelPosixLink -> [Anchor] -> Text -> ExceptT VerifyError IO ()
checkAnchorReferenceAmbiguity RelPosixLink
filePath [Anchor]
fileAnchors Text
anchor = do
      let similarAnchors :: [Anchor]
similarAnchors = (Anchor -> Bool) -> [Anchor] -> [Anchor]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
anchorNameEq Text
anchor (Text -> Bool) -> (Anchor -> Text) -> Anchor -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anchor -> Text
aName) [Anchor]
fileAnchors
      Bool -> ExceptT VerifyError IO () -> ExceptT VerifyError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Anchor] -> Int
forall t. Container t => t -> Int
length [Anchor]
similarAnchors Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (ExceptT VerifyError IO () -> ExceptT VerifyError IO ())
-> ExceptT VerifyError IO () -> ExceptT VerifyError IO ()
forall a b. (a -> b) -> a -> b
$
        VerifyError -> ExceptT VerifyError IO ()
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError -> ExceptT VerifyError IO ())
-> VerifyError -> ExceptT VerifyError IO ()
forall a b. (a -> b) -> a -> b
$ RelPosixLink -> Text -> NonEmpty Anchor -> VerifyError
AmbiguousAnchorRef RelPosixLink
filePath Text
anchor ([Item (NonEmpty Anchor)] -> NonEmpty Anchor
forall l. IsList l => [Item l] -> l
Exts.fromList [Item (NonEmpty Anchor)]
[Anchor]
similarAnchors)

    -- Similar to the previous one, but for the case when we reference the
    -- renamed duplicate.
    checkDeduplicatedAnchorReference :: RelPosixLink -> [Anchor] -> Text -> ExceptT VerifyError IO ()
checkDeduplicatedAnchorReference RelPosixLink
filePath [Anchor]
fileAnchors Text
anchor =
      Maybe Text
-> (Text -> ExceptT VerifyError IO ()) -> ExceptT VerifyError IO ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust (Text -> Maybe Text
stripAnchorDupNo Text
anchor) ((Text -> ExceptT VerifyError IO ()) -> ExceptT VerifyError IO ())
-> (Text -> ExceptT VerifyError IO ()) -> ExceptT VerifyError IO ()
forall a b. (a -> b) -> a -> b
$ \Text
origAnchor ->
        RelPosixLink -> [Anchor] -> Text -> ExceptT VerifyError IO ()
checkAnchorReferenceAmbiguity RelPosixLink
filePath [Anchor]
fileAnchors Text
origAnchor

    checkAnchorExists :: [Anchor] -> Text -> ExceptT VerifyError IO ()
checkAnchorExists [Anchor]
givenAnchors Text
anchor =
      case (Element [Anchor] -> Bool) -> [Anchor] -> Maybe (Element [Anchor])
forall t.
Container t =>
(Element t -> Bool) -> t -> Maybe (Element t)
find (Text -> Text -> Bool
anchorNameEq Text
anchor (Text -> Bool) -> (Anchor -> Text) -> Anchor -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anchor -> Text
aName) [Anchor]
givenAnchors of
        Just Element [Anchor]
_ -> ExceptT VerifyError IO ()
forall (f :: * -> *). Applicative f => f ()
pass
        Maybe (Element [Anchor])
Nothing ->
          let isSimilar :: Double -> Bool
isSimilar = (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= ScannersConfig' Identity -> Field Identity Double
forall (f :: * -> *). ScannersConfig' f -> Field f Double
scAnchorSimilarityThreshold ScannersConfig' Identity
cScanners)
              distance :: Text -> Text -> Ratio Int
distance = Text -> Text -> Ratio Int
damerauLevenshteinNorm (Text -> Text -> Ratio Int)
-> (Text -> Text) -> Text -> Text -> Ratio Int
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Text -> Text
toCaseFold
              similarAnchors :: [Anchor]
similarAnchors = ((Anchor -> Bool) -> [Anchor] -> [Anchor])
-> [Anchor] -> (Anchor -> Bool) -> [Anchor]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Anchor -> Bool) -> [Anchor] -> [Anchor]
forall a. (a -> Bool) -> [a] -> [a]
filter [Anchor]
givenAnchors
                ((Anchor -> Bool) -> [Anchor]) -> (Anchor -> Bool) -> [Anchor]
forall a b. (a -> b) -> a -> b
$ Double -> Bool
isSimilar
                (Double -> Bool) -> (Anchor -> Double) -> Anchor -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ratio Int -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
                (Ratio Int -> Double) -> (Anchor -> Ratio Int) -> Anchor -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Ratio Int
distance Text
anchor
                (Text -> Ratio Int) -> (Anchor -> Text) -> Anchor -> Ratio Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anchor -> Text
aName
          in VerifyError -> ExceptT VerifyError IO ()
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError -> ExceptT VerifyError IO ())
-> VerifyError -> ExceptT VerifyError IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Anchor] -> VerifyError
AnchorDoesNotExist Text
anchor [Anchor]
similarAnchors

checkExternalResource :: RedirectChain -> Config -> Text -> ExceptT VerifyError IO ()
checkExternalResource :: RedirectChain -> Config -> Text -> ExceptT VerifyError IO ()
checkExternalResource RedirectChain
followed config :: Config
config@Config{Field Identity (ExclusionConfig' Identity)
Field Identity (NetworkingConfig' Identity)
ScannersConfig' Identity
cExclusions :: forall (f :: * -> *). Config' f -> Field f (ExclusionConfig' f)
cNetworking :: forall (f :: * -> *). Config' f -> Field f (NetworkingConfig' f)
cScanners :: forall (f :: * -> *). Config' f -> ScannersConfig' f
cExclusions :: Field Identity (ExclusionConfig' Identity)
cNetworking :: Field Identity (NetworkingConfig' Identity)
cScanners :: ScannersConfig' Identity
..} Text
link
  | Bool
isIgnored = ExceptT VerifyError IO ()
forall (f :: * -> *). Applicative f => f ()
pass
  | RedirectChain
followed RedirectChain -> RedirectChainLink -> Bool
`hasRequest` (Text -> RedirectChainLink
RedirectChainLink Text
link) =
      VerifyError -> ExceptT VerifyError IO ()
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError -> ExceptT VerifyError IO ())
-> VerifyError -> ExceptT VerifyError IO ()
forall a b. (a -> b) -> a -> b
$ RedirectChain -> VerifyError
RedirectChainCycle (RedirectChain -> VerifyError) -> RedirectChain -> VerifyError
forall a b. (a -> b) -> a -> b
$ RedirectChain
followed RedirectChain -> RedirectChainLink -> RedirectChain
`pushRequest` (Text -> RedirectChainLink
RedirectChainLink Text
link)
  | Int
Field Identity Int
ncMaxRedirectFollows Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& RedirectChain -> Int
totalFollowed RedirectChain
followed Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
Field Identity Int
ncMaxRedirectFollows =
      VerifyError -> ExceptT VerifyError IO ()
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError -> ExceptT VerifyError IO ())
-> VerifyError -> ExceptT VerifyError IO ()
forall a b. (a -> b) -> a -> b
$ RedirectChain -> VerifyError
RedirectChainLimit (RedirectChain -> VerifyError) -> RedirectChain -> VerifyError
forall a b. (a -> b) -> a -> b
$ RedirectChain
followed RedirectChain -> RedirectChainLink -> RedirectChain
`pushRequest` (Text -> RedirectChainLink
RedirectChainLink Text
link)
  | Bool
otherwise = do
      URI
uri <- UriParseError -> VerifyError
ExternalResourceUriParseError (UriParseError -> VerifyError)
-> ExceptT UriParseError IO URI -> ExceptT VerifyError IO URI
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
`withExceptT` Bool -> Text -> ExceptT UriParseError IO URI
parseUri Bool
False Text
link
      case RText 'Scheme -> String
forall a. ToString a => a -> String
toString (RText 'Scheme -> String) -> Maybe (RText 'Scheme) -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URI -> Maybe (RText 'Scheme)
uriScheme URI
uri of
        Just String
"http" -> URI -> ExceptT VerifyError IO ()
checkHttp URI
uri
        Just String
"https" -> URI -> ExceptT VerifyError IO ()
checkHttp URI
uri
        Just String
"ftp" -> URI -> Bool -> ExceptT VerifyError IO ()
checkFtp URI
uri Bool
False
        Just String
"ftps" -> URI -> Bool -> ExceptT VerifyError IO ()
checkFtp URI
uri Bool
True
        Maybe String
_ -> VerifyError -> ExceptT VerifyError IO ()
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError VerifyError
ExternalResourceUnknownProtocol
  where
    ExclusionConfig{Field Identity [Regex]
Field Identity [CanonicalRelGlobPattern]
ecIgnoreRefsFrom :: forall (f :: * -> *).
ExclusionConfig' f -> Field f [CanonicalRelGlobPattern]
ecIgnoreLocalRefsTo :: forall (f :: * -> *).
ExclusionConfig' f -> Field f [CanonicalRelGlobPattern]
ecIgnore :: Field Identity [CanonicalRelGlobPattern]
ecIgnoreLocalRefsTo :: Field Identity [CanonicalRelGlobPattern]
ecIgnoreRefsFrom :: Field Identity [CanonicalRelGlobPattern]
ecIgnoreExternalRefsTo :: Field Identity [Regex]
ecIgnore :: forall (f :: * -> *).
ExclusionConfig' f -> Field f [CanonicalRelGlobPattern]
ecIgnoreExternalRefsTo :: forall (f :: * -> *). ExclusionConfig' f -> Field f [Regex]
..} = Field Identity (ExclusionConfig' Identity)
cExclusions
    NetworkingConfig{Field Identity Bool
Field Identity Int
Field Identity RedirectConfig
Field Identity (Time Second)
ncDefaultRetryAfter :: forall (f :: * -> *). NetworkingConfig' f -> Field f (Time Second)
ncMaxRetries :: forall (f :: * -> *). NetworkingConfig' f -> Field f Int
ncMaxTimeoutRetries :: forall (f :: * -> *). NetworkingConfig' f -> Field f Int
ncMaxRedirectFollows :: Field Identity Int
ncExternalRefCheckTimeout :: Field Identity (Time Second)
ncIgnoreAuthFailures :: Field Identity Bool
ncDefaultRetryAfter :: Field Identity (Time Second)
ncMaxRetries :: Field Identity Int
ncMaxTimeoutRetries :: Field Identity Int
ncExternalRefRedirects :: Field Identity RedirectConfig
ncExternalRefCheckTimeout :: forall (f :: * -> *). NetworkingConfig' f -> Field f (Time Second)
ncIgnoreAuthFailures :: forall (f :: * -> *). NetworkingConfig' f -> Field f Bool
ncMaxRedirectFollows :: forall (f :: * -> *). NetworkingConfig' f -> Field f Int
ncExternalRefRedirects :: forall (f :: * -> *). NetworkingConfig' f -> Field f RedirectConfig
..} = Field Identity (NetworkingConfig' Identity)
cNetworking

    isIgnored :: Bool
isIgnored = Text -> [Regex] -> Bool
doesMatchAnyRegex Text
link [Regex]
Field Identity [Regex]
ecIgnoreExternalRefsTo

    checkHttp :: URI -> ExceptT VerifyError IO ()
    checkHttp :: URI -> ExceptT VerifyError IO ()
checkHttp URI
uri = URI -> HEAD -> RatioNat -> ExceptT VerifyError IO ()
forall method.
(HttpMethod method, HttpBodyAllowed (AllowsBody method) 'NoBody) =>
URI -> method -> RatioNat -> ExceptT VerifyError IO ()
makeHttpRequest URI
uri HEAD
HEAD RatioNat
0.3 ExceptT VerifyError IO ()
-> (VerifyError -> ExceptT VerifyError IO ())
-> ExceptT VerifyError IO ()
forall a.
ExceptT VerifyError IO a
-> (VerifyError -> ExceptT VerifyError IO a)
-> ExceptT VerifyError IO a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \case
      e :: VerifyError
e@(ExternalHttpTooManyRequests Maybe RetryAfter
_ Maybe DomainName
_) -> VerifyError -> ExceptT VerifyError IO ()
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError VerifyError
e
      VerifyError
_ -> URI -> GET -> RatioNat -> ExceptT VerifyError IO ()
forall method.
(HttpMethod method, HttpBodyAllowed (AllowsBody method) 'NoBody) =>
URI -> method -> RatioNat -> ExceptT VerifyError IO ()
makeHttpRequest URI
uri GET
GET RatioNat
0.7

    httpConfig :: HttpConfig
    httpConfig :: HttpConfig
httpConfig = HttpConfig
defaultHttpConfig { httpConfigRedirectCount = 0 }

    makeHttpRequest
      :: (HttpMethod method, HttpBodyAllowed (AllowsBody method) 'NoBody)
      => URI
      -> method
      -> RatioNat
      -> ExceptT VerifyError IO ()
    makeHttpRequest :: forall method.
(HttpMethod method, HttpBodyAllowed (AllowsBody method) 'NoBody) =>
URI -> method -> RatioNat -> ExceptT VerifyError IO ()
makeHttpRequest URI
uri method
method RatioNat
timeoutFrac = do
      Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
parsedUrl <- case URI
-> Maybe
     (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
forall (scheme0 :: Scheme) (scheme1 :: Scheme).
URI
-> Maybe
     (Either (Url 'Http, Option scheme0) (Url 'Https, Option scheme1))
useURI URI
uri of
        -- accordingly to source code - Nothing can be only in case when
        -- protocol is not http or https, but we've checked it already
        -- so just in case we throw exception here
        Maybe
  (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
Nothing -> VerifyError
-> ExceptT
     VerifyError
     IO
     (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError
 -> ExceptT
      VerifyError
      IO
      (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)))
-> VerifyError
-> ExceptT
     VerifyError
     IO
     (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
forall a b. (a -> b) -> a -> b
$ Maybe Text -> VerifyError
ExternalResourceInvalidUrl Maybe Text
forall a. Maybe a
Nothing
        Just Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
u -> Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
-> ExceptT
     VerifyError
     IO
     (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
forall a. a -> ExceptT VerifyError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
u

      let reqLink :: IO IgnoreResponse
reqLink = case Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
parsedUrl of
            Left (Url 'Http
url, Option 'Http
option) ->
              HttpConfig -> Req IgnoreResponse -> IO IgnoreResponse
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
httpConfig (Req IgnoreResponse -> IO IgnoreResponse)
-> Req IgnoreResponse -> IO IgnoreResponse
forall a b. (a -> b) -> a -> b
$
                method
-> Url 'Http
-> NoReqBody
-> Proxy IgnoreResponse
-> Option 'Http
-> Req IgnoreResponse
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req method
method Url 'Http
url NoReqBody
NoReqBody Proxy IgnoreResponse
ignoreResponse Option 'Http
option
            Right (Url 'Https
url, Option 'Https
option) ->
              HttpConfig -> Req IgnoreResponse -> IO IgnoreResponse
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
httpConfig (Req IgnoreResponse -> IO IgnoreResponse)
-> Req IgnoreResponse -> IO IgnoreResponse
forall a b. (a -> b) -> a -> b
$
                method
-> Url 'Https
-> NoReqBody
-> Proxy IgnoreResponse
-> Option 'Https
-> Req IgnoreResponse
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req method
method Url 'Https
url NoReqBody
NoReqBody Proxy IgnoreResponse
ignoreResponse Option 'Https
option

      let maxTime :: Time Second
maxTime = forall (rat :: Rat). RatioNat -> Time rat
Time @Second (RatioNat -> Time Second) -> RatioNat -> Time Second
forall a b. (a -> b) -> a -> b
$ Time (1 :% 1) -> RatioNat
forall (rat :: Rat). Time rat -> RatioNat
unTime Time (1 :% 1)
Field Identity (Time Second)
ncExternalRefCheckTimeout RatioNat -> RatioNat -> RatioNat
forall a. Num a => a -> a -> a
* RatioNat
timeoutFrac

      Maybe ResponseResult
reqRes <- ExceptT VerifyError IO (Maybe ResponseResult)
-> (HttpException -> ExceptT VerifyError IO (Maybe ResponseResult))
-> ExceptT VerifyError IO (Maybe ResponseResult)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (IO (Maybe ResponseResult)
-> ExceptT VerifyError IO (Maybe ResponseResult)
forall a. IO a -> ExceptT VerifyError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Time (1 :% 1) -> IO ResponseResult -> IO (Maybe ResponseResult)
forall (unit :: Rat) (m :: * -> *) a.
(MonadIO m, KnownDivRat unit Microsecond) =>
Time unit -> IO a -> m (Maybe a)
timeout Time Second
Time (1 :% 1)
maxTime (IO ResponseResult -> IO (Maybe ResponseResult))
-> IO ResponseResult -> IO (Maybe ResponseResult)
forall a b. (a -> b) -> a -> b
$ IO IgnoreResponse
reqLink IO IgnoreResponse -> ResponseResult -> IO ResponseResult
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ResponseResult
RRDone)) ((HttpException -> ExceptT VerifyError IO (Maybe ResponseResult))
 -> ExceptT VerifyError IO (Maybe ResponseResult))
-> (HttpException -> ExceptT VerifyError IO (Maybe ResponseResult))
-> ExceptT VerifyError IO (Maybe ResponseResult)
forall a b. (a -> b) -> a -> b
$
         (ResponseResult -> Maybe ResponseResult
forall a. a -> Maybe a
Just (ResponseResult -> Maybe ResponseResult)
-> ExceptT VerifyError IO ResponseResult
-> ExceptT VerifyError IO (Maybe ResponseResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (ExceptT VerifyError IO ResponseResult
 -> ExceptT VerifyError IO (Maybe ResponseResult))
-> (HttpException -> ExceptT VerifyError IO ResponseResult)
-> HttpException
-> ExceptT VerifyError IO (Maybe ResponseResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URI -> HttpException -> ExceptT VerifyError IO ResponseResult
interpretHttpErrors URI
uri

      case Maybe ResponseResult
reqRes of
        Maybe ResponseResult
Nothing -> VerifyError -> ExceptT VerifyError IO ()
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError -> ExceptT VerifyError IO ())
-> VerifyError -> ExceptT VerifyError IO ()
forall a b. (a -> b) -> a -> b
$ Maybe DomainName -> VerifyError
ExternalHttpTimeout (Maybe DomainName -> VerifyError)
-> Maybe DomainName -> VerifyError
forall a b. (a -> b) -> a -> b
$ URI -> Maybe DomainName
extractHost URI
uri
        Just ResponseResult
RRDone -> ExceptT VerifyError IO ()
forall (f :: * -> *). Applicative f => f ()
pass
        Just (RRFollow Text
nextLink) ->
          RedirectChain -> Config -> Text -> ExceptT VerifyError IO ()
checkExternalResource (RedirectChain
followed RedirectChain -> RedirectChainLink -> RedirectChain
`pushRequest` (Text -> RedirectChainLink
RedirectChainLink Text
link)) Config
config Text
nextLink

    extractHost :: URI -> Maybe DomainName
    extractHost :: URI -> Maybe DomainName
extractHost =
      (Bool -> Maybe DomainName)
-> (Authority -> Maybe DomainName)
-> Either Bool Authority
-> Maybe DomainName
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe DomainName -> Bool -> Maybe DomainName
forall a b. a -> b -> a
const Maybe DomainName
forall a. Maybe a
Nothing) (DomainName -> Maybe DomainName
forall a. a -> Maybe a
Just (DomainName -> Maybe DomainName)
-> (Authority -> DomainName) -> Authority -> Maybe DomainName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DomainName
DomainName (Text -> DomainName)
-> (Authority -> Text) -> Authority -> DomainName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RText 'Host -> Text
forall (l :: RTextLabel). RText l -> Text
unRText (RText 'Host -> Text)
-> (Authority -> RText 'Host) -> Authority -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Authority -> RText 'Host
authHost) (Either Bool Authority -> Maybe DomainName)
-> (URI -> Either Bool Authority) -> URI -> Maybe DomainName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> Either Bool Authority
uriAuthority

    isAllowedErrorCode :: Int -> Bool
    isAllowedErrorCode :: Int -> Bool
isAllowedErrorCode = [Bool] -> Bool
forall t. (Container t, Element t ~ Bool) => t -> Bool
or ([Bool] -> Bool) -> (Int -> [Bool]) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int -> Bool] -> Int -> [Bool]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
      -- We have to stay conservative - if some URL can be accessed under
      -- some circumstances, we should do our best to report it as fine.
      [ if Bool
Field Identity Bool
ncIgnoreAuthFailures -- unauthorized access
        then (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
403, Int
401]
        else Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
False
      , (Int
405 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==) -- method mismatch
      ]

    interpretHttpErrors :: URI -> Network.HTTP.Req.HttpException -> ExceptT VerifyError IO ResponseResult
    interpretHttpErrors :: URI -> HttpException -> ExceptT VerifyError IO ResponseResult
interpretHttpErrors URI
uri = \case
      JsonHttpException String
_ -> Text -> ExceptT VerifyError IO ResponseResult
forall a. HasCallStack => Text -> a
error Text
"External link JSON parse exception"
      VanillaHttpException HttpException
err -> URI -> HttpException -> ExceptT VerifyError IO ResponseResult
interpretHttpErrors' URI
uri HttpException
err

    interpretHttpErrors' :: URI -> Network.HTTP.Client.HttpException -> ExceptT VerifyError IO ResponseResult
    interpretHttpErrors' :: URI -> HttpException -> ExceptT VerifyError IO ResponseResult
interpretHttpErrors' URI
uri = \case
        InvalidUrlException{} -> Text -> ExceptT VerifyError IO ResponseResult
forall a. HasCallStack => Text -> a
error Text
"External link URL invalid exception"
        HttpExceptionRequest Request
_ HttpExceptionContent
exc -> case HttpExceptionContent
exc of
          StatusCodeException Response ()
resp ByteString
_
            | Int -> Bool
isRedirectCode Int
code -> case Maybe Text
redirectLocation of
                Maybe Text
Nothing -> VerifyError -> ExceptT VerifyError IO ResponseResult
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError -> ExceptT VerifyError IO ResponseResult)
-> VerifyError -> ExceptT VerifyError IO ResponseResult
forall a b. (a -> b) -> a -> b
$ RedirectChain -> VerifyError
RedirectMissingLocation (RedirectChain -> VerifyError) -> RedirectChain -> VerifyError
forall a b. (a -> b) -> a -> b
$ RedirectChain
followed RedirectChain -> RedirectChainLink -> RedirectChain
`pushRequest` Text -> RedirectChainLink
RedirectChainLink Text
link
                Just Text
nextLink -> do
                  URI
nextUri <- UriParseError -> VerifyError
ExternalResourceUriParseError (UriParseError -> VerifyError)
-> ExceptT UriParseError IO URI -> ExceptT VerifyError IO URI
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
`withExceptT` Bool -> Text -> ExceptT UriParseError IO URI
parseUri Bool
True Text
nextLink
                  Text
nextLinkAbsolute <- case URI -> URI -> Maybe URI
relativeTo URI
nextUri URI
uri of
                    -- This should not happen because uri has been parsed with `parseUri False`
                    Maybe URI
Nothing -> Text -> ExceptT VerifyError IO Text
forall a. HasCallStack => Text -> a
error Text
"Not an absolute URL exception"
                    Just URI
absoluteTarget -> Text -> ExceptT VerifyError IO Text
forall a. a -> ExceptT VerifyError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ExceptT VerifyError IO Text)
-> Text -> ExceptT VerifyError IO Text
forall a b. (a -> b) -> a -> b
$ URI -> Text
render URI
absoluteTarget
                  case Text -> Text -> Int -> RedirectConfig -> Maybe RedirectRule
redirectRule Text
link Text
nextLinkAbsolute Int
code RedirectConfig
Field Identity RedirectConfig
ncExternalRefRedirects of
                    Maybe RedirectRule
Nothing -> ResponseResult -> ExceptT VerifyError IO ResponseResult
forall a. a -> ExceptT VerifyError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseResult
RRDone
                    Just RedirectRule{Maybe Regex
Maybe RedirectRuleOn
RedirectRuleOutcome
rrFrom :: Maybe Regex
rrTo :: Maybe Regex
rrOn :: Maybe RedirectRuleOn
rrOutcome :: RedirectRuleOutcome
rrFrom :: RedirectRule -> Maybe Regex
rrTo :: RedirectRule -> Maybe Regex
rrOn :: RedirectRule -> Maybe RedirectRuleOn
rrOutcome :: RedirectRule -> RedirectRuleOutcome
..} ->
                      case RedirectRuleOutcome
rrOutcome of
                        RedirectRuleOutcome
RROValid -> ResponseResult -> ExceptT VerifyError IO ResponseResult
forall a. a -> ExceptT VerifyError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseResult
RRDone
                        RedirectRuleOutcome
RROInvalid -> VerifyError -> ExceptT VerifyError IO ResponseResult
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError -> ExceptT VerifyError IO ResponseResult)
-> VerifyError -> ExceptT VerifyError IO ResponseResult
forall a b. (a -> b) -> a -> b
$ RedirectChain -> Maybe RedirectRuleOn -> VerifyError
RedirectRuleError
                          (RedirectChain
followed RedirectChain -> RedirectChainLink -> RedirectChain
`pushRequest` Text -> RedirectChainLink
RedirectChainLink Text
link RedirectChain -> RedirectChainLink -> RedirectChain
`pushRequest` Text -> RedirectChainLink
RedirectChainLink Text
nextLinkAbsolute)
                          Maybe RedirectRuleOn
rrOn
                        RedirectRuleOutcome
RROFollow -> ResponseResult -> ExceptT VerifyError IO ResponseResult
forall a. a -> ExceptT VerifyError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResponseResult -> ExceptT VerifyError IO ResponseResult)
-> ResponseResult -> ExceptT VerifyError IO ResponseResult
forall a b. (a -> b) -> a -> b
$ Text -> ResponseResult
RRFollow Text
nextLinkAbsolute
            | Int -> Bool
isAllowedErrorCode Int
code -> ResponseResult -> ExceptT VerifyError IO ResponseResult
forall a. a -> ExceptT VerifyError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseResult
RRDone
            | Bool
otherwise -> case Status -> Int
statusCode (Response () -> Status
forall body. Response body -> Status
responseStatus Response ()
resp) of
                Int
429 -> VerifyError -> ExceptT VerifyError IO ResponseResult
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError -> ExceptT VerifyError IO ResponseResult)
-> VerifyError -> ExceptT VerifyError IO ResponseResult
forall a b. (a -> b) -> a -> b
$ Maybe RetryAfter -> Maybe DomainName -> VerifyError
ExternalHttpTooManyRequests (Response () -> Maybe RetryAfter
forall a. Response a -> Maybe RetryAfter
retryAfterInfo Response ()
resp) (URI -> Maybe DomainName
extractHost URI
uri)
                Int
_ -> VerifyError -> ExceptT VerifyError IO ResponseResult
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError -> ExceptT VerifyError IO ResponseResult)
-> VerifyError -> ExceptT VerifyError IO ResponseResult
forall a b. (a -> b) -> a -> b
$ Status -> VerifyError
ExternalHttpResourceUnavailable (Status -> VerifyError) -> Status -> VerifyError
forall a b. (a -> b) -> a -> b
$ Response () -> Status
forall body. Response body -> Status
responseStatus Response ()
resp
            where
              code :: Int
              code :: Int
code = Status -> Int
statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response () -> Status
forall body. Response body -> Status
responseStatus Response ()
resp

              redirectLocation :: Maybe Text
              redirectLocation :: Maybe Text
redirectLocation = (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8
                (Maybe ByteString -> Maybe Text)
-> (ResponseHeaders -> Maybe ByteString)
-> ResponseHeaders
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Location"
                (ResponseHeaders -> Maybe Text) -> ResponseHeaders -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Response () -> ResponseHeaders
forall body. Response body -> ResponseHeaders
responseHeaders Response ()
resp

          ConnectionFailure SomeException
_ -> VerifyError -> ExceptT VerifyError IO ResponseResult
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError VerifyError
ExternalResourceConnectionFailure
          InternalException SomeException
e
            | Just (N.C.HostCannotConnect String
_ [IOException]
_) <- SomeException -> Maybe HostCannotConnect
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e
            -> VerifyError -> ExceptT VerifyError IO ResponseResult
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError VerifyError
ExternalResourceConnectionFailure

          HttpExceptionContent
other -> VerifyError -> ExceptT VerifyError IO ResponseResult
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError -> ExceptT VerifyError IO ResponseResult)
-> VerifyError -> ExceptT VerifyError IO ResponseResult
forall a b. (a -> b) -> a -> b
$ Text -> VerifyError
ExternalResourceSomeError (Text -> VerifyError) -> Text -> VerifyError
forall a b. (a -> b) -> a -> b
$ HttpExceptionContent -> Text
forall b a. (Show a, IsString b) => a -> b
show HttpExceptionContent
other
      where
        retryAfterInfo :: Response a -> Maybe RetryAfter
        retryAfterInfo :: forall a. Response a -> Maybe RetryAfter
retryAfterInfo =
          forall b a. (ToString a, Read b) => a -> Maybe b
readMaybe @_ @Text (Text -> Maybe RetryAfter)
-> (ByteString -> Text) -> ByteString -> Maybe RetryAfter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Maybe RetryAfter)
-> (Response a -> Maybe ByteString)
-> Response a
-> Maybe RetryAfter
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=<
          HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup HeaderName
hRetryAfter (ResponseHeaders -> Maybe ByteString)
-> (Response a -> ResponseHeaders)
-> Response a
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response a -> ResponseHeaders
forall body. Response body -> ResponseHeaders
responseHeaders

    checkFtp :: URI -> Bool -> ExceptT VerifyError IO ()
    checkFtp :: URI -> Bool -> ExceptT VerifyError IO ()
checkFtp URI
uri Bool
secure = do
      -- get authority which stores host and port
      Authority
authority <- case URI -> Either Bool Authority
uriAuthority URI
uri of
        Right Authority
a -> Authority -> ExceptT VerifyError IO Authority
forall a. a -> ExceptT VerifyError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Authority
a
        Left Bool
_ -> VerifyError -> ExceptT VerifyError IO Authority
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError -> ExceptT VerifyError IO Authority)
-> VerifyError -> ExceptT VerifyError IO Authority
forall a b. (a -> b) -> a -> b
$
          Maybe Text -> VerifyError
ExternalResourceInvalidUrl (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"FTP path must be absolute")
      let host :: String
host = RText 'Host -> String
forall a. ToString a => a -> String
toString (RText 'Host -> String) -> RText 'Host -> String
forall a b. (a -> b) -> a -> b
$ Authority -> RText 'Host
authHost Authority
authority
      Int
port :: Int <- case Word -> Maybe Int
forall a b.
(Integral a, Integral b, Bits a, Bits b) =>
a -> Maybe b
toIntegralSized (Word -> Maybe Int)
-> (Maybe Word -> Word) -> Maybe Word -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Maybe Word -> Word
forall a. a -> Maybe a -> a
fromMaybe Word
21 (Maybe Word -> Maybe Int) -> Maybe Word -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Authority -> Maybe Word
authPort Authority
authority of
        Just Int
p -> Int -> ExceptT VerifyError IO Int
forall a. a -> ExceptT VerifyError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
p
        Maybe Int
Nothing -> VerifyError -> ExceptT VerifyError IO Int
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError -> ExceptT VerifyError IO Int)
-> VerifyError -> ExceptT VerifyError IO Int
forall a b. (a -> b) -> a -> b
$
          Maybe Text -> VerifyError
ExternalResourceInvalidUrl (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Bad port")
      -- build path from pieces
      String
path <- case URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath URI
uri of
        Maybe (Bool, NonEmpty (RText 'PathPiece))
Nothing -> String -> ExceptT VerifyError IO String
forall a. a -> ExceptT VerifyError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
""
        Just (Bool
_, NonEmpty (RText 'PathPiece)
pieces) -> String -> ExceptT VerifyError IO String
forall a. a -> ExceptT VerifyError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          (String -> ExceptT VerifyError IO String)
-> (NonEmpty (RText 'PathPiece) -> String)
-> NonEmpty (RText 'PathPiece)
-> ExceptT VerifyError IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. Monoid a => [a] -> a
mconcat
          ([String] -> String)
-> (NonEmpty (RText 'PathPiece) -> [String])
-> NonEmpty (RText 'PathPiece)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"/"
          ([String] -> [String])
-> (NonEmpty (RText 'PathPiece) -> [String])
-> NonEmpty (RText 'PathPiece)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RText 'PathPiece -> String) -> [RText 'PathPiece] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map RText 'PathPiece -> String
forall a. ToString a => a -> String
toString
          ([RText 'PathPiece] -> [String])
-> (NonEmpty (RText 'PathPiece) -> [RText 'PathPiece])
-> NonEmpty (RText 'PathPiece)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (RText 'PathPiece) -> [RText 'PathPiece]
NonEmpty (RText 'PathPiece)
-> [Element (NonEmpty (RText 'PathPiece))]
forall t. Container t => t -> [Element t]
toList
          (NonEmpty (RText 'PathPiece) -> ExceptT VerifyError IO String)
-> NonEmpty (RText 'PathPiece) -> ExceptT VerifyError IO String
forall a b. (a -> b) -> a -> b
$ NonEmpty (RText 'PathPiece)
pieces
      String -> Int -> String -> Bool -> ExceptT VerifyError IO ()
makeFtpRequest String
host Int
port String
path Bool
secure ExceptT VerifyError IO ()
-> (FTPException -> ExceptT VerifyError IO ())
-> ExceptT VerifyError IO ()
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \FTPException
e ->
        VerifyError -> ExceptT VerifyError IO ()
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError -> ExceptT VerifyError IO ())
-> VerifyError -> ExceptT VerifyError IO ()
forall a b. (a -> b) -> a -> b
$ FTPException -> VerifyError
ExternalFtpException FTPException
e

    makeFtpRequest
      :: String
      -> Int
      -> FilePath
      -> Bool
      -> ExceptT VerifyError IO ()
    makeFtpRequest :: String -> Int -> String -> Bool -> ExceptT VerifyError IO ()
makeFtpRequest String
host Int
port String
path Bool
secure = String
-> Int
-> (Handle -> FTPResponse -> ExceptT VerifyError IO ())
-> ExceptT VerifyError IO ()
handler String
host Int
port ((Handle -> FTPResponse -> ExceptT VerifyError IO ())
 -> ExceptT VerifyError IO ())
-> (Handle -> FTPResponse -> ExceptT VerifyError IO ())
-> ExceptT VerifyError IO ()
forall a b. (a -> b) -> a -> b
$
      \Handle
ftpHandle FTPResponse
response -> do
        -- check connection status
        Bool -> ExceptT VerifyError IO () -> ExceptT VerifyError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FTPResponse -> ResponseStatus
frStatus FTPResponse
response ResponseStatus -> ResponseStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= ResponseStatus
Success) (ExceptT VerifyError IO () -> ExceptT VerifyError IO ())
-> ExceptT VerifyError IO () -> ExceptT VerifyError IO ()
forall a b. (a -> b) -> a -> b
$
          VerifyError -> ExceptT VerifyError IO ()
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError -> ExceptT VerifyError IO ())
-> VerifyError -> ExceptT VerifyError IO ()
forall a b. (a -> b) -> a -> b
$ FTPResponse -> VerifyError
ExternalFtpResourceUnavailable FTPResponse
response
        -- anonymous login
        FTPResponse
loginResp <- Handle -> String -> String -> ExceptT VerifyError IO FTPResponse
forall (m :: * -> *).
MonadIO m =>
Handle -> String -> String -> m FTPResponse
login Handle
ftpHandle String
"anonymous" String
""
        -- check login status
        Bool -> ExceptT VerifyError IO () -> ExceptT VerifyError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FTPResponse -> ResponseStatus
frStatus FTPResponse
loginResp ResponseStatus -> ResponseStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= ResponseStatus
Success) (ExceptT VerifyError IO () -> ExceptT VerifyError IO ())
-> ExceptT VerifyError IO () -> ExceptT VerifyError IO ()
forall a b. (a -> b) -> a -> b
$
          if Bool
Field Identity Bool
ncIgnoreAuthFailures
          then () -> ExceptT VerifyError IO ()
forall a. a -> ExceptT VerifyError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          else VerifyError -> ExceptT VerifyError IO ()
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError -> ExceptT VerifyError IO ())
-> VerifyError -> ExceptT VerifyError IO ()
forall a b. (a -> b) -> a -> b
$ FTPException -> VerifyError
ExternalFtpException (FTPException -> VerifyError) -> FTPException -> VerifyError
forall a b. (a -> b) -> a -> b
$ FTPResponse -> FTPException
UnsuccessfulException FTPResponse
loginResp
        -- If the response is non-null, the path is definitely a directory;
        -- If the response is null, the path may be a file or may not exist.
        ByteString
dirList <- Handle -> [String] -> ExceptT VerifyError IO ByteString
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
Handle -> [String] -> m ByteString
nlst Handle
ftpHandle [ String
"-a", String
path ]
        Bool -> ExceptT VerifyError IO () -> ExceptT VerifyError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
BS.null ByteString
dirList) (ExceptT VerifyError IO () -> ExceptT VerifyError IO ())
-> ExceptT VerifyError IO () -> ExceptT VerifyError IO ()
forall a b. (a -> b) -> a -> b
$ do
          -- The server-PI will respond to the SIZE command with a 213 reply
          -- giving the transfer size of the file whose pathname was supplied,
          -- or an error response if the file does not exist, the size is
          -- unavailable, or some other error has occurred.
          Int
_ <- Handle -> String -> ExceptT VerifyError IO Int
forall (m :: * -> *). MonadIO m => Handle -> String -> m Int
size Handle
ftpHandle String
path ExceptT VerifyError IO Int
-> (FTPException -> ExceptT VerifyError IO Int)
-> ExceptT VerifyError IO Int
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \case
              UnsuccessfulException FTPResponse
_ -> VerifyError -> ExceptT VerifyError IO Int
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError -> ExceptT VerifyError IO Int)
-> VerifyError -> ExceptT VerifyError IO Int
forall a b. (a -> b) -> a -> b
$ String -> VerifyError
FtpEntryDoesNotExist String
path
              FailureException FTPResponse{Int
ResponseStatus
FTPMessage
frStatus :: FTPResponse -> ResponseStatus
frStatus :: ResponseStatus
frCode :: Int
frMessage :: FTPMessage
frCode :: FTPResponse -> Int
frMessage :: FTPResponse -> FTPMessage
..} | Int
frCode Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
550 ->
                VerifyError -> ExceptT VerifyError IO Int
forall a. VerifyError -> ExceptT VerifyError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError -> ExceptT VerifyError IO Int)
-> VerifyError -> ExceptT VerifyError IO Int
forall a b. (a -> b) -> a -> b
$ String -> VerifyError
FtpEntryDoesNotExist String
path
              FTPException
err -> IO Int -> ExceptT VerifyError IO Int
forall a. IO a -> ExceptT VerifyError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> ExceptT VerifyError IO Int)
-> IO Int -> ExceptT VerifyError IO Int
forall a b. (a -> b) -> a -> b
$ FTPException -> IO Int
forall e a. Exception e => e -> IO a
throwIO FTPException
err
          () -> ExceptT VerifyError IO ()
forall a. a -> ExceptT VerifyError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      where
        handler :: String
-> Int
-> (Handle -> FTPResponse -> ExceptT VerifyError IO ())
-> ExceptT VerifyError IO ()
handler = if Bool
secure then String
-> Int
-> (Handle -> FTPResponse -> ExceptT VerifyError IO ())
-> ExceptT VerifyError IO ()
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
String -> Int -> (Handle -> FTPResponse -> m a) -> m a
withFTPS else String
-> Int
-> (Handle -> FTPResponse -> ExceptT VerifyError IO ())
-> ExceptT VerifyError IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> Int -> (Handle -> FTPResponse -> m a) -> m a
withFTP

----------------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------------

-- | @loopAsyncUntil ma mb@ will continually run @ma@ until @mb@ throws an exception or returns.
-- Once it does, it'll wait for @ma@ to finish running one last time and then return.
--
-- See #163 to read more on why it's important to let @ma@ finish cleanly.
-- * https://github.com/serokell/xrefcheck/issues/162
-- * https://github.com/serokell/xrefcheck/pull/163
loopAsyncUntil :: forall a b. IO a -> IO b -> IO b
loopAsyncUntil :: forall a b. IO a -> IO b -> IO b
loopAsyncUntil IO a
loopingAction IO b
action =
  ((forall a. IO a -> IO a) -> IO b) -> IO b
forall b.
HasCallStack =>
((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. IO a -> IO a) -> IO b) -> IO b)
-> ((forall a. IO a -> IO a) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    IORef Bool
shouldLoop <- Bool -> IO (IORef Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Bool
True
    Async ()
loopingActionAsync <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO ()
loopingAction' IORef Bool
shouldLoop
    IO b -> IO b
forall a. IO a -> IO a
restore IO b
action IO b -> IO () -> IO b
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` do
      IORef Bool -> Bool -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef Bool
shouldLoop Bool
False
      Async () -> IO ()
forall a. Async a -> IO a
wait Async ()
loopingActionAsync
  where
    loopingAction' :: IORef Bool -> IO ()
    loopingAction' :: IORef Bool -> IO ()
loopingAction' IORef Bool
shouldLoop = do
      IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (IORef Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Bool
shouldLoop) do
        IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO a
loopingAction
        IORef Bool -> IO ()
loopingAction' IORef Bool
shouldLoop