xrefcheck-0.3.0: src/Xrefcheck/Verify.hs
{- 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 (Show, Eq, Functor)
deriving newtype instance Semigroup (VerifyResult e)
deriving newtype instance Monoid (VerifyResult e)
verifyErrors :: VerifyResult e -> Maybe (NonEmpty e)
verifyErrors (VerifyResult errors) = nonEmpty errors
verifying :: Monad m => ExceptT e m () -> m (VerifyResult e)
verifying (ExceptT action) = fmap toVerifyRes action
toVerifyRes :: Either e () -> VerifyResult e
toVerifyRes = VerifyResult . either one (\() -> [])
-----------------------------------------------------------
-- Cross-references validation
-----------------------------------------------------------
data WithReferenceLoc a = WithReferenceLoc
{ wrlFile :: RelPosixLink
, wrlReference :: Reference
, wrlItem :: a
}
-- | Contains a name of a domain, examples:
-- @DomainName "github.com"@,
-- @DomainName "localhost"@,
-- @DomainName "192.168.0.104"@
newtype DomainName = DomainName { unDomainName :: Text }
deriving stock (Show, Eq, 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 (Show, Eq)
data ResponseResult
= RRDone
| RRFollow Text
pprVerifyErr' :: Given ColorMode => ReferenceInfo -> VerifyError -> Builder
pprVerifyErr' rInfo = \case
LocalFileDoesNotExist 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 file ->
[int||
Link #{pprLinkTyp rInfo} targets a local file outside the repository:
#{file}
|]
LinkTargetNotAddedToGit 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 anchor similar -> case nonEmpty similar of
Nothing ->
[int||
Anchor '#{anchor}' is not present
|]
Just otherAnchors ->
[int||
Anchor '#{anchor}' is not present, did you mean:
#{interpolateIndentF 2 $ interpolateBlockListF otherAnchors}
|]
AmbiguousAnchorRef file 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 err) ->
[int||
Invalid URI (#{err})
|] <> pprLinkCtx rInfo
ExternalResourceUriParseError (UPEConversion err) ->
[int||
Invalid URI
#{interpolateIndentF 2 . build $ displayException err}
|] <> pprLinkCtx rInfo
ExternalResourceInvalidUrl Nothing ->
[int||
Invalid URL
|] <> pprLinkCtx rInfo
ExternalResourceInvalidUrl (Just message) ->
[int||
Invalid URL (#{message})
|] <> pprLinkCtx rInfo
ExternalResourceUnknownProtocol ->
[int||
Bad url (expected 'http','https', 'ftp' or 'ftps')
|] <> pprLinkCtx rInfo
ExternalHttpResourceUnavailable status ->
[int||
Resource unavailable (#{statusCode status} #{decodeUtf8 @Text (statusMessage status)})
|] <> pprLinkCtx rInfo
ExternalHttpTooManyRequests retryAfter _ ->
[int||
Resource unavailable (429 Too Many Requests; retry after #{maybeF retryAfter})
|] <> pprLinkCtx rInfo
ExternalHttpTimeout _ ->
[int||
Response timeout
|] <> pprLinkCtx rInfo
ExternalFtpResourceUnavailable response ->
[int||
Resource unavailable:
#{response}
|] <> pprLinkCtx rInfo
ExternalFtpException err ->
[int||
FTP exception (#{err})
|] <> pprLinkCtx rInfo
FtpEntryDoesNotExist entry ->
[int||
File or directory does not exist:
#{entry}
|]
ExternalResourceSomeError err ->
[int||
#{err}
|] <> pprLinkCtx rInfo
ExternalResourceConnectionFailure ->
[int||
Connection failure
|] <> pprLinkCtx rInfo
RedirectChainCycle chain ->
[int||
Cycle found in the following redirect chain:
#{interpolateIndentF 2 $ attachToRedirectChain chain "here"}
|] <> pprLinkCtx rInfo
RedirectMissingLocation chain ->
[int||
Missing location header in the following redirect chain:
#{interpolateIndentF 2 $ attachToRedirectChain chain "no location header"}
|] <> pprLinkCtx rInfo
RedirectChainLimit chain ->
[int||
The follow redirects limit has been reached in the following redirect chain:
#{interpolateIndentF 2 $ attachToRedirectChain chain "stopped before this one"}
|] <> pprLinkCtx rInfo
RedirectRuleError chain mOn ->
[int||
#{redirect} found:
#{interpolateIndentF 2 $ attachToRedirectChain chain "stopped before this one"}
|] <> pprLinkCtx rInfo
where
redirect :: Text
redirect = case mOn of
Nothing -> "Redirect"
Just RROPermanent -> "Permanent redirect"
Just RROTemporary -> "Temporary redirect"
Just (RROCode code) -> show code <> " redirect"
attachToRedirectChain :: RedirectChain -> Text -> Builder
attachToRedirectChain chain attached
= build chain <> build attachedText
where
attachedText = "\n ^-- " <> attached
data RetryCounter = RetryCounter
{ rcTotalRetries :: Int
, rcTimeoutRetries :: Int
} deriving stock (Show)
incTotalCounter :: RetryCounter -> RetryCounter
incTotalCounter rc = rc {rcTotalRetries = rcTotalRetries rc + 1}
incTimeoutCounter :: RetryCounter -> RetryCounter
incTimeoutCounter rc = rc {rcTimeoutRetries = rcTimeoutRetries rc + 1}
pprVerifyErr :: Given ColorMode => WithReferenceLoc VerifyError -> Builder
pprVerifyErr wrl = hdr <> "\n" <> interpolateIndentF 2 msg
where
WithReferenceLoc{wrlReference, wrlItem} = wrl
Reference{rName, rInfo} = wrlReference
hdr, msg :: Builder
hdr =
styleIfNeeded Bold (build (rPos wrlReference) <> ": ") <>
colorIfNeeded Red "bad reference:"
msg =
"The reference to " <> show rName <> " failed verification.\n" <>
pprVerifyErr' rInfo wrlItem
pprLink :: Given ColorMode => ReferenceInfo -> Maybe (Builder, Builder)
pprLink = \case
RIFile ReferenceInfoFile{..} ->
case rifLink of
FLLocal -> Nothing
FLRelative link -> Just ("a " <> styleIfNeeded Faint "relative" <> " link", build link)
FLAbsolute link -> Just ("an " <> styleIfNeeded Faint "absolute" <> " link", build link)
RIExternal (ELUrl url) -> Just ("an " <> styleIfNeeded Faint "external" <> " link", build url)
RIExternal (ELOther url) -> Just ("a link", build url)
pprLinkTyp :: Given ColorMode => ReferenceInfo -> Builder
pprLinkTyp rInfo =
paren $ styleIfNeeded Faint $ case rInfo of
RIFile ReferenceInfoFile{rifLink} ->
case rifLink of
FLLocal -> "file-local"
FLRelative _ -> "relative"
FLAbsolute _ -> "absolute"
RIExternal _ -> "external"
pprLinkCtx :: Given ColorMode => ReferenceInfo -> Builder
pprLinkCtx rInfo =
case pprLink rInfo of
Nothing -> mempty
Just (b1, b2) -> "when processing " <> b1 <> ":\n" <> interpolateIndentF 2 b2 <> "\n"
reportVerifyErrs
:: Given ColorMode => NonEmpty (WithReferenceLoc VerifyError) -> IO ()
reportVerifyErrs errs = do
traverse_ (fmtLn . pprVerifyErr) errs
fmtLn $ colorIfNeeded Red $
"Invalid references dumped, " <> build (length errs) <> " in total."
data RetryAfter = Date UTCTime | Seconds (Time Second)
deriving stock (Show, Eq)
instance Read RetryAfter where
readPrec = asum
[ ReadPrec.lift $ Date <$> readPTime True defaultTimeLocale rfc822DateFormat
, readPrec @Natural <&> Seconds . sec . fromIntegral @_ @RatioNat
]
instance Buildable RetryAfter where
build (Date d) = nameF "date" $
fromString $ formatTime defaultTimeLocale rfc822DateFormat d
build (Seconds s) = nameF "seconds" $ show 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 list needsCaching action = go [] M.empty list
where
go
:: [Async b]
-> Map cacheKey (Async b)
-> [a]
-> IO (Either (AsyncException, [b]) [b])
go acc cached items =
case items of
(x : xs) -> case needsCaching x of
NoCaching -> do
withAsync (action x) $ \b ->
go (b : acc) cached xs
CacheUnderKey cacheKey -> do
case M.lookup cacheKey cached of
Nothing -> do
withAsync (action x) $ \b ->
go (b : acc) (M.insert cacheKey b cached) xs
Just b -> go (b : acc) cached xs
[] -> 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
UserInterrupt -> do
partialResults <- for acc \asyncAction -> do
cancel asyncAction
poll asyncAction <&> \case
Just (Right a) -> Just a
Just (Left _ex) -> Nothing
Nothing -> Nothing
pure $ Left (UserInterrupt, catMaybes partialResults)
otherAsyncEx -> throwM otherAsyncEx
)
$ Right . reverse <$> for acc 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
rw
config@Config{..}
mode
repoInfo@RepoInfo{..}
= do
let toScan = do
(canonicalFile, (file, fileInfo)) <- toPairs riFiles
guard . not $ matchesGlobPatterns (ecIgnoreRefsFrom cExclusions) canonicalFile
case fileInfo of
Scanned fi -> do
ref <- _fiReferences fi
return (file, ref)
NotScannable -> empty -- No support for such file, can do nothing.
NotAddedToGit -> empty -- If this file is scannable, we've notified
-- user that we are scanning only files
-- added to Git while gathering RepoInfo.
progressRef <- newIORef $ initVerifyProgress (map snd toScan)
domainsReturned429Ref <- newIORef S.empty
accumulated <- loopAsyncUntil (printer progressRef) do
forConcurrentlyCaching toScan ifExternalThenCache $ \(file, ref) ->
verifyReference config mode domainsReturned429Ref progressRef repoInfo file ref
case accumulated of
Right res -> return $ fold res
Left (exception, partialRes) -> do
-- The user has hit Ctrl+C; display any verification errors we managed to find and exit.
let errs = verifyErrors (fold partialRes)
total = length toScan
checked = length partialRes
whenJust errs reportVerifyErrs
fmt [int|A|
Interrupted (#s{exception}), checked #{checked} out of #{total} references.
|]
exitFailure
where
printer :: IORef VerifyProgress -> IO ()
printer progressRef = do
posixTime <- getPOSIXTime <&> posixTimeToTimeSecond
progress <- atomicModifyIORef' progressRef $ \VerifyProgress{..} ->
let prog = VerifyProgress{ vrExternal =
checkTaskTimestamp posixTime vrExternal
, ..
}
in (prog, prog)
reprintAnalyseProgress rw mode posixTime progress
-- Slight pause so we're not refreshing the progress bar more often than needed.
threadDelay (ms 100)
ifExternalThenCache :: (a, Reference) -> NeedsCaching Text
ifExternalThenCache (_, Reference{..}) =
case rInfo of
RIExternal (ELUrl url) ->
CacheUnderKey url
_ ->
NoCaching
shouldCheckLocType :: VerifyMode -> ReferenceInfo -> Bool
shouldCheckLocType mode rInfo =
case rInfo of
RIFile _ -> shouldCheckLocal mode
RIExternal (ELUrl _) -> shouldCheckExternal mode
RIExternal (ELOther _) -> False
verifyReference
:: Config
-> VerifyMode
-> IORef (S.Set DomainName)
-> IORef VerifyProgress
-> RepoInfo
-> RelPosixLink
-> Reference
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
verifyReference
config@Config{..}
mode
domainsReturned429Ref
progressRef
repoInfo
file
ref@Reference{..}
= fmap (fmap addReference . toVerifyRes) $
retryVerification (RetryCounter 0 0) $ runExceptT $
if shouldCheckLocType mode rInfo
then case rInfo of
RIFile ReferenceInfoFile{..} ->
case rifLink of
FLLocal ->
checkRef rifAnchor file
FLRelative link ->
checkRef rifAnchor $ takeDirectory file </> link
FLAbsolute link ->
checkRef rifAnchor link
RIExternal (ELUrl url) ->
checkExternalResource emptyChain config url
RIExternal (ELOther _) ->
pass
else pass
where
addReference :: VerifyError -> WithReferenceLoc VerifyError
addReference = WithReferenceLoc file ref
retryVerification
:: RetryCounter
-> IO (Either VerifyError ())
-> IO (Either VerifyError ())
retryVerification rc resIO = do
res <- resIO
case res of
-- Success
Right () -> modifyProgressRef Nothing reportSuccess $> res
Left err -> do
setOfReturned429 <- addDomainIf429 domainsReturned429Ref err
case decideWhetherToRetry setOfReturned429 rc err of
-- Unfixable
Nothing -> modifyProgressRef Nothing reportError $> res
-- Fixable, retry
Just (mbCurrentRetryAfter, counterModifier) -> do
now <- getPOSIXTime <&> posixTimeToTimeSecond
let toSeconds = \case
Seconds s -> s
-- Calculates the seconds left until @Retry-After@ date.
-- Defaults to 0 if the date has already passed.
Date date | utcTimeToTimeSecond date >= now -> utcTimeToTimeSecond date -:- now
_ -> sec 0
let currentRetryAfter = fromMaybe (ncDefaultRetryAfter cNetworking) $
fmap toSeconds mbCurrentRetryAfter
modifyProgressRef (Just (now, currentRetryAfter)) reportRetry
threadDelay currentRetryAfter
retryVerification (counterModifier rc) resIO
modifyProgressRef
:: Maybe (Time Second, Time Second)
-> (forall w. Ord w => w -> Progress Int w -> Progress Int w)
-> IO ()
modifyProgressRef mbRetryData moveProgress = atomicModifyIORef' progressRef $ \VerifyProgress{..} ->
( case rInfo of
RIFile _ -> VerifyProgress{ vrLocal = moveProgress () vrLocal, .. }
RIExternal (ELOther _) -> VerifyProgress{ vrLocal = moveProgress () vrLocal, .. }
RIExternal (ELUrl url) -> VerifyProgress{ vrExternal =
let vrExternalAdvanced = moveProgress url vrExternal
in case mbRetryData of
Just (now, retryAfter) -> case getTaskTimestamp vrExternal of
Just (TaskTimestamp ttc start)
| retryAfter +:+ now <= ttc +:+ start -> vrExternalAdvanced
_ -> setTaskTimestamp url retryAfter now vrExternalAdvanced
Nothing -> vrExternalAdvanced, .. }
, ()
)
addDomainIf429 :: IORef (S.Set DomainName) -> VerifyError -> IO (S.Set DomainName)
addDomainIf429 setRef err = atomicModifyIORef' setRef $ \s ->
(\x -> (x, x)) $ case err of
ExternalHttpTooManyRequests _ mbDomain ->
maybe s (flip S.insert s) mbDomain
_ -> s
decideWhetherToRetry
:: S.Set DomainName
-> RetryCounter
-> VerifyError
-> Maybe (Maybe RetryAfter, RetryCounter -> RetryCounter)
decideWhetherToRetry setOfReturned429 rc = \case
ExternalHttpTooManyRequests retryAfter _
| totalRetriesNotExceeded -> Just (retryAfter, incTotalCounter)
ExternalHttpTimeout (Just domain)
| totalRetriesNotExceeded && 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 S.member domain setOfReturned429
then Just (Just (Seconds $ sec 0), incTimeoutCounter . incTotalCounter)
else Nothing
_ -> Nothing
where
totalRetriesNotExceeded = rcTotalRetries rc < ncMaxRetries cNetworking
timeoutRetriesNotExceeded = rcTimeoutRetries rc < ncMaxTimeoutRetries cNetworking
isVirtual = matchesGlobPatterns (ecIgnoreLocalRefsTo cExclusions)
-- Checks a local file reference.
checkRef :: Maybe Text -> RelPosixLink -> ExceptT VerifyError IO ()
checkRef mAnchor referredFile = do
let canonicalFile = canonicalizeRelPosixLink referredFile
unless (isVirtual canonicalFile) do
when (hasUnexpanededParentIndirections canonicalFile) $
throwError $ LocalFileOutsideRepo referredFile
mFileStatus <- tryGetFileStatus referredFile
case mFileStatus of
Right (Scanned referredFileInfo) -> whenJust mAnchor $
checkAnchor referredFile (_fiAnchors referredFileInfo)
Right NotAddedToGit -> throwError (LinkTargetNotAddedToGit referredFile)
Left UntrackedDirectory -> throwError (LinkTargetNotAddedToGit referredFile)
Right NotScannable -> pass -- no support for such file, can do nothing
Left TrackedDirectory -> pass -- path leads to directory, currently
-- if such link contain anchor, we ignore it
caseInsensitive = caseInsensitiveAnchors . mcFlavor . scMarkdown $ cScanners
-- Returns `Nothing` when path corresponds to an existing (and tracked) directory
tryGetFileStatus :: RelPosixLink -> ExceptT VerifyError IO (Either DirectoryStatus FileStatus)
tryGetFileStatus filePath
| Just f <- lookupFile canonicalFile repoInfo = return (Right f)
| Just d <- lookupDirectory canonicalFile repoInfo = return (Left d)
| otherwise = throwError (LocalFileDoesNotExist filePath)
where
canonicalFile = canonicalizeRelPosixLink filePath
checkAnchor filePath fileAnchors anchor = do
checkAnchorReferenceAmbiguity filePath fileAnchors anchor
checkDeduplicatedAnchorReference filePath fileAnchors anchor
checkAnchorExists fileAnchors anchor
anchorNameEq =
if caseInsensitive
then (==) `on` toCaseFold
else (==)
-- 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 filePath fileAnchors anchor = do
let similarAnchors = filter (anchorNameEq anchor . aName) fileAnchors
when (length similarAnchors > 1) $
throwError $ AmbiguousAnchorRef filePath anchor (Exts.fromList similarAnchors)
-- Similar to the previous one, but for the case when we reference the
-- renamed duplicate.
checkDeduplicatedAnchorReference filePath fileAnchors anchor =
whenJust (stripAnchorDupNo anchor) $ \origAnchor ->
checkAnchorReferenceAmbiguity filePath fileAnchors origAnchor
checkAnchorExists givenAnchors anchor =
case find (anchorNameEq anchor . aName) givenAnchors of
Just _ -> pass
Nothing ->
let isSimilar = (>= scAnchorSimilarityThreshold cScanners)
distance = damerauLevenshteinNorm `on` toCaseFold
similarAnchors = flip filter givenAnchors
$ isSimilar
. realToFrac
. distance anchor
. aName
in throwError $ AnchorDoesNotExist anchor similarAnchors
checkExternalResource :: RedirectChain -> Config -> Text -> ExceptT VerifyError IO ()
checkExternalResource followed config@Config{..} link
| isIgnored = pass
| followed `hasRequest` (RedirectChainLink link) =
throwError $ RedirectChainCycle $ followed `pushRequest` (RedirectChainLink link)
| ncMaxRedirectFollows >= 0 && totalFollowed followed > ncMaxRedirectFollows =
throwError $ RedirectChainLimit $ followed `pushRequest` (RedirectChainLink link)
| otherwise = do
uri <- ExternalResourceUriParseError `withExceptT` parseUri False link
case toString <$> uriScheme uri of
Just "http" -> checkHttp uri
Just "https" -> checkHttp uri
Just "ftp" -> checkFtp uri False
Just "ftps" -> checkFtp uri True
_ -> throwError ExternalResourceUnknownProtocol
where
ExclusionConfig{..} = cExclusions
NetworkingConfig{..} = cNetworking
isIgnored = doesMatchAnyRegex link ecIgnoreExternalRefsTo
checkHttp :: URI -> ExceptT VerifyError IO ()
checkHttp uri = makeHttpRequest uri HEAD 0.3 `catchError` \case
e@(ExternalHttpTooManyRequests _ _) -> throwError e
_ -> makeHttpRequest uri GET 0.7
httpConfig :: HttpConfig
httpConfig = defaultHttpConfig { httpConfigRedirectCount = 0 }
makeHttpRequest
:: (HttpMethod method, HttpBodyAllowed (AllowsBody method) 'NoBody)
=> URI
-> method
-> RatioNat
-> ExceptT VerifyError IO ()
makeHttpRequest uri method timeoutFrac = do
parsedUrl <- case useURI 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
Nothing -> throwError $ ExternalResourceInvalidUrl Nothing
Just u -> pure u
let reqLink = case parsedUrl of
Left (url, option) ->
runReq httpConfig $
req method url NoReqBody ignoreResponse option
Right (url, option) ->
runReq httpConfig $
req method url NoReqBody ignoreResponse option
let maxTime = Time @Second $ unTime ncExternalRefCheckTimeout * timeoutFrac
reqRes <- catch (liftIO (timeout maxTime $ reqLink $> RRDone)) $
(Just <$>) <$> interpretHttpErrors uri
case reqRes of
Nothing -> throwError $ ExternalHttpTimeout $ extractHost uri
Just RRDone -> pass
Just (RRFollow nextLink) ->
checkExternalResource (followed `pushRequest` (RedirectChainLink link)) config nextLink
extractHost :: URI -> Maybe DomainName
extractHost =
either (const Nothing) (Just . DomainName . unRText . authHost) . uriAuthority
isAllowedErrorCode :: Int -> Bool
isAllowedErrorCode = or . 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 ncIgnoreAuthFailures -- unauthorized access
then flip elem [403, 401]
else const False
, (405 ==) -- method mismatch
]
interpretHttpErrors :: URI -> Network.HTTP.Req.HttpException -> ExceptT VerifyError IO ResponseResult
interpretHttpErrors uri = \case
JsonHttpException _ -> error "External link JSON parse exception"
VanillaHttpException err -> interpretHttpErrors' uri err
interpretHttpErrors' :: URI -> Network.HTTP.Client.HttpException -> ExceptT VerifyError IO ResponseResult
interpretHttpErrors' uri = \case
InvalidUrlException{} -> error "External link URL invalid exception"
HttpExceptionRequest _ exc -> case exc of
StatusCodeException resp _
| isRedirectCode code -> case redirectLocation of
Nothing -> throwError $ RedirectMissingLocation $ followed `pushRequest` RedirectChainLink link
Just nextLink -> do
nextUri <- ExternalResourceUriParseError `withExceptT` parseUri True nextLink
nextLinkAbsolute <- case relativeTo nextUri uri of
-- This should not happen because uri has been parsed with `parseUri False`
Nothing -> error "Not an absolute URL exception"
Just absoluteTarget -> pure $ render absoluteTarget
case redirectRule link nextLinkAbsolute code ncExternalRefRedirects of
Nothing -> pure RRDone
Just RedirectRule{..} ->
case rrOutcome of
RROValid -> pure RRDone
RROInvalid -> throwError $ RedirectRuleError
(followed `pushRequest` RedirectChainLink link `pushRequest` RedirectChainLink nextLinkAbsolute)
rrOn
RROFollow -> pure $ RRFollow nextLinkAbsolute
| isAllowedErrorCode code -> pure RRDone
| otherwise -> case statusCode (responseStatus resp) of
429 -> throwError $ ExternalHttpTooManyRequests (retryAfterInfo resp) (extractHost uri)
_ -> throwError $ ExternalHttpResourceUnavailable $ responseStatus resp
where
code :: Int
code = statusCode $ responseStatus resp
redirectLocation :: Maybe Text
redirectLocation = fmap decodeUtf8
. lookup "Location"
$ responseHeaders resp
ConnectionFailure _ -> throwError ExternalResourceConnectionFailure
InternalException e
| Just (N.C.HostCannotConnect _ _) <- fromException e
-> throwError ExternalResourceConnectionFailure
other -> throwError $ ExternalResourceSomeError $ show other
where
retryAfterInfo :: Response a -> Maybe RetryAfter
retryAfterInfo =
readMaybe @_ @Text . decodeUtf8 <=<
L.lookup hRetryAfter . responseHeaders
checkFtp :: URI -> Bool -> ExceptT VerifyError IO ()
checkFtp uri secure = do
-- get authority which stores host and port
authority <- case uriAuthority uri of
Right a -> pure a
Left _ -> throwError $
ExternalResourceInvalidUrl (Just "FTP path must be absolute")
let host = toString $ authHost authority
port :: Int <- case toIntegralSized . fromMaybe 21 $ authPort authority of
Just p -> pure p
Nothing -> throwError $
ExternalResourceInvalidUrl (Just "Bad port")
-- build path from pieces
path <- case uriPath uri of
Nothing -> pure ""
Just (_, pieces) -> pure
. mconcat
. intersperse "/"
. map toString
. toList
$ pieces
makeFtpRequest host port path secure `catch` \e ->
throwError $ ExternalFtpException e
makeFtpRequest
:: String
-> Int
-> FilePath
-> Bool
-> ExceptT VerifyError IO ()
makeFtpRequest host port path secure = handler host port $
\ftpHandle response -> do
-- check connection status
when (frStatus response /= Success) $
throwError $ ExternalFtpResourceUnavailable response
-- anonymous login
loginResp <- login ftpHandle "anonymous" ""
-- check login status
when (frStatus loginResp /= Success) $
if ncIgnoreAuthFailures
then pure ()
else throwError $ ExternalFtpException $ UnsuccessfulException 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.
dirList <- nlst ftpHandle [ "-a", path ]
when (BS.null dirList) $ 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.
_ <- size ftpHandle path `catch` \case
UnsuccessfulException _ -> throwError $ FtpEntryDoesNotExist path
FailureException FTPResponse{..} | frCode == 550 ->
throwError $ FtpEntryDoesNotExist path
err -> liftIO $ throwIO err
pure ()
where
handler = if secure then withFTPS else 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 loopingAction action =
mask $ \restore -> do
shouldLoop <- newIORef True
loopingActionAsync <- async $ restore $ loopingAction' shouldLoop
restore action `finally` do
writeIORef shouldLoop False
wait loopingActionAsync
where
loopingAction' :: IORef Bool -> IO ()
loopingAction' shouldLoop = do
whenM (readIORef shouldLoop) do
void loopingAction
loopingAction' shouldLoop