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

{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}

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

    , WithReferenceLoc (..)

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

import Control.Concurrent.Async (forConcurrently, withAsync)
import Control.Monad.Except (MonadError (..))
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Text.Metrics (damerauLevenshteinNorm)
import Fmt (Buildable (..), blockListF', listF, (+|), (|+))
import qualified GHC.Exts as Exts
import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), responseStatus)
import Network.HTTP.Req (GET (..), HEAD (..), HttpException (..), NoReqBody (..), defaultHttpConfig,
                         ignoreResponse, req, runReq, useURI)
import Network.HTTP.Types.Status (Status, statusCode, statusMessage)
import System.Console.Pretty (Style (..), style)
import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist)
import System.FilePath (takeDirectory, (</>))
import qualified System.FilePath.Glob as Glob
import Text.Regex.TDFA.Text (Regex, regexec)
import Text.URI (mkURI)
import Time (RatioNat, Second, Time (..), ms, threadDelay, timeout)

import Xrefcheck.Config
import Xrefcheck.Core
import Xrefcheck.Progress
import Xrefcheck.System

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

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

newtype VerifyResult e = VerifyResult [e]
    deriving (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
showList :: [VerifyResult e] -> ShowS
$cshowList :: forall e. Show e => [VerifyResult e] -> ShowS
show :: VerifyResult e -> String
$cshow :: forall e. Show e => VerifyResult e -> String
showsPrec :: Int -> VerifyResult e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> VerifyResult e -> ShowS
Show, a -> VerifyResult b -> VerifyResult a
(a -> b) -> VerifyResult a -> VerifyResult b
(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
<$ :: a -> VerifyResult b -> VerifyResult a
$c<$ :: forall a b. a -> VerifyResult b -> VerifyResult a
fmap :: (a -> b) -> VerifyResult a -> VerifyResult b
$cfmap :: forall a b. (a -> b) -> VerifyResult a -> VerifyResult b
Functor)

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

instance Buildable e => Buildable (VerifyResult e) where
    build :: VerifyResult e -> Builder
build VerifyResult e
vr = case VerifyResult e -> Maybe (NonEmpty e)
forall e. VerifyResult e -> Maybe (NonEmpty e)
verifyErrors VerifyResult e
vr of
        Maybe (NonEmpty e)
Nothing   -> Builder
"ok"
        Just NonEmpty e
errs -> NonEmpty e -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
listF NonEmpty e
errs

verifyOk :: VerifyResult e -> Bool
verifyOk :: VerifyResult e -> Bool
verifyOk (VerifyResult [e]
errors) = [e] -> Bool
forall t. Container t => t -> Bool
null [e]
errors

verifyErrors :: VerifyResult e -> Maybe (NonEmpty e)
verifyErrors :: 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 :: ExceptT e m () -> m (VerifyResult e)
verifying (ExceptT m (Either e ())
action) = (Either e () -> VerifyResult e)
-> m (Either e ()) -> m (VerifyResult e)
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 :: 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]
forall x. One x => OneItem x -> x
one (\() -> [])

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

data WithReferenceLoc a = WithReferenceLoc
    { WithReferenceLoc a -> String
wrlFile      :: FilePath
    , WithReferenceLoc a -> Reference
wrlReference :: Reference
    , WithReferenceLoc a -> a
wrlItem      :: a
    }

instance Buildable a => Buildable (WithReferenceLoc a) where
    build :: WithReferenceLoc a -> Builder
build WithReferenceLoc{a
String
Reference
wrlItem :: a
wrlReference :: Reference
wrlFile :: String
wrlItem :: forall a. WithReferenceLoc a -> a
wrlReference :: forall a. WithReferenceLoc a -> Reference
wrlFile :: forall a. WithReferenceLoc a -> String
..} =
        Builder
"In file " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Style -> ShowS
forall a. Pretty a => Style -> a -> a
style Style
Faint (Style -> ShowS
forall a. Pretty a => Style -> a -> a
style Style
Bold String
wrlFile) String -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"\nbad " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Reference
wrlReference Reference -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"\n"
        Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| a
wrlItem a -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"\n\n"

data VerifyError
    = FileDoesNotExist FilePath
    | AnchorDoesNotExist Text [Anchor]
    | AmbiguousAnchorRef FilePath Text (NonEmpty Anchor)
    | ExternalResourceInvalidUri
    | ExternalResourceUnknownProtocol
    | ExternalResourceUnavailable Status
    | ExternalResourceSomeError Text
    deriving (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
showList :: [VerifyError] -> ShowS
$cshowList :: [VerifyError] -> ShowS
show :: VerifyError -> String
$cshow :: VerifyError -> String
showsPrec :: Int -> VerifyError -> ShowS
$cshowsPrec :: Int -> VerifyError -> ShowS
Show)

instance Buildable VerifyError where
    build :: VerifyError -> Builder
build = \case
        FileDoesNotExist String
file ->
            Builder
"⛀  File does not exist:\n   " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| String
file String -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"\n"
        AnchorDoesNotExist Text
anchor [Anchor]
similar ->
            Builder
"⛀  Anchor '" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Text
anchor Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"' is not present" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|
            [Anchor] -> Builder
anchorHints [Anchor]
similar
        AmbiguousAnchorRef String
file Text
anchor NonEmpty Anchor
fileAnchors ->
            Builder
"⛀  Ambiguous reference to anchor '" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Text
anchor Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"'\n   " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|
            Builder
"In file " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| String
file String -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"\n   " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|
            Builder
"Similar anchors are:\n" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|
                Text -> (Anchor -> Builder) -> NonEmpty Anchor -> Builder
forall (f :: * -> *) a.
Foldable f =>
Text -> (a -> Builder) -> f a -> Builder
blockListF' Text
"    -" Anchor -> Builder
forall p. Buildable p => p -> Builder
build NonEmpty Anchor
fileAnchors Builder -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|
            Builder
"   Use of such anchors is discouraged because referenced object\n\
            \   can change silently whereas the document containing it evolves.\n"
        VerifyError
ExternalResourceInvalidUri ->
            Builder
"⛂  Invalid url\n"
        VerifyError
ExternalResourceUnknownProtocol ->
            Builder
"⛂  Bad url (expected 'http' or 'https')\n"
        ExternalResourceUnavailable Status
status ->
            Builder
"⛂  Resource unavailable (" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Status -> Int
statusCode Status
status Int -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|
            ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 @Text (Status -> ByteString
statusMessage Status
status) Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
")\n"
        ExternalResourceSomeError Text
err ->
            Builder
"⛂  " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Text -> Builder
forall p. Buildable p => p -> Builder
build Text
err Builder -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"\n\n"
      where
        anchorHints :: [Anchor] -> Builder
anchorHints = \case
            []  -> Builder
"\n"
            [Anchor
h] -> Builder
",\n   did you mean " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Anchor
h Anchor -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"?\n"
            [Anchor]
hs  -> Builder
", did you mean:\n" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Text -> (Anchor -> Builder) -> [Anchor] -> Builder
forall (f :: * -> *) a.
Foldable f =>
Text -> (a -> Builder) -> f a -> Builder
blockListF' Text
"    -" Anchor -> Builder
forall p. Buildable p => p -> Builder
build [Anchor]
hs

verifyRepo
    :: Rewrite
    -> VerifyConfig
    -> VerifyMode
    -> FilePath
    -> RepoInfo
    -> IO (VerifyResult $ WithReferenceLoc VerifyError)
verifyRepo :: Rewrite
-> VerifyConfig
-> VerifyMode
-> String
-> RepoInfo
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
verifyRepo Rewrite
rw config :: VerifyConfig
config@VerifyConfig{Double
[String]
[RelGlobPattern]
Maybe [Regex]
Time Second
vcIgnoreRefs :: VerifyConfig -> Maybe [Regex]
vcNotScanned :: VerifyConfig -> [String]
vcVirtualFiles :: VerifyConfig -> [RelGlobPattern]
vcExternalRefCheckTimeout :: VerifyConfig -> Time Second
vcAnchorSimilarityThreshold :: VerifyConfig -> Double
vcIgnoreRefs :: Maybe [Regex]
vcNotScanned :: [String]
vcVirtualFiles :: [RelGlobPattern]
vcExternalRefCheckTimeout :: Time Second
vcAnchorSimilarityThreshold :: Double
..} VerifyMode
mode String
root repoInfo' :: RepoInfo
repoInfo'@(RepoInfo Map String FileInfo
repoInfo) = do
    let toScan :: [(String, Reference)]
toScan = do
          (String
file, FileInfo
fileInfo) <- Map String FileInfo -> [(String, FileInfo)]
forall k a. Map k a -> [(k, a)]
M.toList Map String FileInfo
repoInfo
          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
$ (Element [String] -> Bool) -> [String] -> Bool
forall t. Container t => (Element t -> Bool) -> t -> Bool
any ((String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
file) (String -> Bool) -> ShowS -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
root String -> ShowS
</>)) [String]
vcNotScanned
          Reference
ref <- FileInfo -> [Reference]
_fiReferences FileInfo
fileInfo
          (String, Reference) -> [(String, Reference)]
forall (m :: * -> *) a. Monad m => a -> m a
return (String
file, Reference
ref)

    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 (((String, Reference) -> Reference)
-> [(String, Reference)] -> [Reference]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (String, Reference) -> Reference
forall a b. (a, b) -> b
snd [(String, Reference)]
toScan)

    IO Any
-> (Async Any -> IO (VerifyResult $ WithReferenceLoc VerifyError))
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (IORef VerifyProgress -> IO Any
printer IORef VerifyProgress
progressRef) ((Async Any -> IO (VerifyResult $ WithReferenceLoc VerifyError))
 -> IO (VerifyResult $ WithReferenceLoc VerifyError))
-> (Async Any -> IO (VerifyResult $ WithReferenceLoc VerifyError))
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
forall a b. (a -> b) -> a -> b
$ \Async Any
_ ->
        ([VerifyResult $ WithReferenceLoc VerifyError]
 -> VerifyResult $ WithReferenceLoc VerifyError)
-> IO [VerifyResult $ WithReferenceLoc VerifyError]
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [VerifyResult $ WithReferenceLoc VerifyError]
-> VerifyResult $ WithReferenceLoc VerifyError
forall t. (Container t, Monoid (Element t)) => t -> Element t
fold (IO [VerifyResult $ WithReferenceLoc VerifyError]
 -> IO (VerifyResult $ WithReferenceLoc VerifyError))
-> (((String, Reference)
     -> IO (VerifyResult $ WithReferenceLoc VerifyError))
    -> IO [VerifyResult $ WithReferenceLoc VerifyError])
-> ((String, Reference)
    -> IO (VerifyResult $ WithReferenceLoc VerifyError))
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, Reference)]
-> ((String, Reference)
    -> IO (VerifyResult $ WithReferenceLoc VerifyError))
-> IO [VerifyResult $ WithReferenceLoc VerifyError]
forall (t :: * -> *) a b.
Traversable t =>
t a -> (a -> IO b) -> IO (t b)
forConcurrently [(String, Reference)]
toScan (((String, Reference)
  -> IO (VerifyResult $ WithReferenceLoc VerifyError))
 -> IO (VerifyResult $ WithReferenceLoc VerifyError))
-> ((String, Reference)
    -> IO (VerifyResult $ WithReferenceLoc VerifyError))
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
forall a b. (a -> b) -> a -> b
$ \(String
file, Reference
ref) ->
            VerifyConfig
-> VerifyMode
-> IORef VerifyProgress
-> RepoInfo
-> String
-> String
-> Reference
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
verifyReference VerifyConfig
config VerifyMode
mode IORef VerifyProgress
progressRef RepoInfo
repoInfo' String
root String
file Reference
ref
  where
    printer :: IORef VerifyProgress -> IO Any
printer IORef VerifyProgress
progressRef = IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ do
        IORef VerifyProgress -> IO VerifyProgress
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef VerifyProgress
progressRef IO VerifyProgress -> (VerifyProgress -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Rewrite -> VerifyMode -> VerifyProgress -> IO ()
reprintAnalyseProgress Rewrite
rw VerifyMode
mode
        Time (1 :% 1000) -> IO ()
forall (unit :: Rat) (m :: * -> *).
(KnownDivRat unit Microsecond, MonadIO m) =>
Time unit -> m ()
threadDelay (RatioNat -> Time Millisecond
ms RatioNat
100)

shouldCheckLocType :: VerifyMode -> LocationType -> Bool
shouldCheckLocType :: VerifyMode -> LocationType -> Bool
shouldCheckLocType VerifyMode
mode LocationType
locType
    | LocationType -> Bool
isExternal LocationType
locType = VerifyMode -> Bool
shouldCheckExternal VerifyMode
mode
    | LocationType -> Bool
isLocal LocationType
locType = VerifyMode -> Bool
shouldCheckLocal VerifyMode
mode
    | Bool
otherwise = Bool
False

verifyReference
    :: VerifyConfig
    -> VerifyMode
    -> IORef VerifyProgress
    -> RepoInfo
    -> FilePath
    -> FilePath
    -> Reference
    -> IO (VerifyResult $ WithReferenceLoc VerifyError)
verifyReference :: VerifyConfig
-> VerifyMode
-> IORef VerifyProgress
-> RepoInfo
-> String
-> String
-> Reference
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
verifyReference config :: VerifyConfig
config@VerifyConfig{Double
[String]
[RelGlobPattern]
Maybe [Regex]
Time Second
vcIgnoreRefs :: Maybe [Regex]
vcNotScanned :: [String]
vcVirtualFiles :: [RelGlobPattern]
vcExternalRefCheckTimeout :: Time Second
vcAnchorSimilarityThreshold :: Double
vcIgnoreRefs :: VerifyConfig -> Maybe [Regex]
vcNotScanned :: VerifyConfig -> [String]
vcVirtualFiles :: VerifyConfig -> [RelGlobPattern]
vcExternalRefCheckTimeout :: VerifyConfig -> Time Second
vcAnchorSimilarityThreshold :: VerifyConfig -> Double
..} VerifyMode
mode IORef VerifyProgress
progressRef (RepoInfo Map String FileInfo
repoInfo)
                String
root String
fileWithReference ref :: Reference
ref@Reference{Maybe Text
Text
Position
rPos :: Reference -> Position
rAnchor :: Reference -> Maybe Text
rLink :: Reference -> Text
rName :: Reference -> Text
rPos :: Position
rAnchor :: Maybe Text
rLink :: Text
rName :: Text
..} = do

    let locType :: LocationType
locType = Text -> LocationType
locationType Text
rLink

    if VerifyMode -> LocationType -> Bool
shouldCheckLocType VerifyMode
mode LocationType
locType
    then do
        VerifyResult VerifyError
res <- case LocationType
locType of
            LocationType
LocalLoc    -> Maybe Text -> String -> IO (VerifyResult VerifyError)
checkRef Maybe Text
rAnchor String
fileWithReference
            LocationType
RelativeLoc -> Maybe Text -> String -> IO (VerifyResult VerifyError)
checkRef Maybe Text
rAnchor
                          (ShowS
takeDirectory String
fileWithReference
                            String -> ShowS
</> Text -> String
forall a. ToString a => a -> String
toString (Text -> Text
canonizeLocalRef Text
rLink))
            LocationType
AbsoluteLoc -> Maybe Text -> String -> IO (VerifyResult VerifyError)
checkRef Maybe Text
rAnchor (String
root String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString Text
rLink)
            LocationType
ExternalLoc -> VerifyConfig -> Text -> IO (VerifyResult VerifyError)
checkExternalResource VerifyConfig
config Text
rLink
            LocationType
OtherLoc    -> ExceptT VerifyError IO () -> IO (VerifyResult VerifyError)
forall (m :: * -> *) e.
Monad m =>
ExceptT e m () -> m (VerifyResult e)
verifying ExceptT VerifyError IO ()
forall (f :: * -> *). Applicative f => f ()
pass

        let moveProgress :: Progress Int -> Progress Int
moveProgress =
                Progress Int -> Progress Int
forall a. (Num a, Show a) => Progress a -> Progress a
incProgress (Progress Int -> Progress Int)
-> (Progress Int -> Progress Int) -> Progress Int -> Progress Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                (if VerifyResult VerifyError -> Bool
forall e. VerifyResult e -> Bool
verifyOk VerifyResult VerifyError
res then Progress Int -> Progress Int
forall a. a -> a
id else Progress Int -> Progress Int
forall a. (Num a, Show a) => Progress a -> Progress a
incProgressErrors)

        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
vrExternal :: VerifyProgress -> Progress Int
vrLocal :: VerifyProgress -> Progress Int
vrExternal :: Progress Int
vrLocal :: Progress Int
..} ->
            ( if LocationType -> Bool
isExternal LocationType
locType
              then VerifyProgress :: Progress Int -> Progress Int -> VerifyProgress
VerifyProgress{ vrExternal :: Progress Int
vrExternal = Progress Int -> Progress Int
moveProgress Progress Int
vrExternal, Progress Int
vrLocal :: Progress Int
vrLocal :: Progress Int
.. }
              else VerifyProgress :: Progress Int -> Progress Int -> VerifyProgress
VerifyProgress{ vrLocal :: Progress Int
vrLocal = Progress Int -> Progress Int
moveProgress Progress Int
vrLocal, Progress Int
vrExternal :: Progress Int
vrExternal :: Progress Int
.. }
            , ()
            )
        (VerifyResult $ WithReferenceLoc VerifyError)
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
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
$ (VerifyError -> WithReferenceLoc VerifyError)
-> VerifyResult VerifyError
-> VerifyResult $ WithReferenceLoc VerifyError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Reference -> VerifyError -> WithReferenceLoc VerifyError
forall a. String -> Reference -> a -> WithReferenceLoc a
WithReferenceLoc String
fileWithReference Reference
ref) VerifyResult VerifyError
res
    else (VerifyResult $ WithReferenceLoc VerifyError)
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
forall (m :: * -> *) a. Monad m => a -> m a
return VerifyResult $ WithReferenceLoc VerifyError
forall a. Monoid a => a
mempty
  where
    checkRef :: Maybe Text -> String -> IO (VerifyResult VerifyError)
checkRef Maybe Text
mAnchor String
referredFile = ExceptT VerifyError IO () -> IO (VerifyResult VerifyError)
forall (m :: * -> *) e.
Monad m =>
ExceptT e m () -> m (VerifyResult e)
verifying (ExceptT VerifyError IO () -> IO (VerifyResult VerifyError))
-> ExceptT VerifyError IO () -> IO (VerifyResult VerifyError)
forall a b. (a -> b) -> a -> b
$ do
        String -> ExceptT VerifyError IO ()
checkReferredFileExists String
referredFile
        case String -> Map String FileInfo -> Maybe FileInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
referredFile Map String FileInfo
repoInfo of
            Maybe FileInfo
Nothing -> ExceptT VerifyError IO ()
forall (f :: * -> *). Applicative f => f ()
pass  -- no support for such file, can do nothing
            Just 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
$ String -> [Anchor] -> Text -> ExceptT VerifyError IO ()
checkAnchor String
referredFile (FileInfo -> [Anchor]
_fiAnchors FileInfo
referredFileInfo)

    checkReferredFileExists :: String -> ExceptT VerifyError IO ()
checkReferredFileExists String
file = do
        let fileExists :: Bool
fileExists = IO Bool -> Bool
forall a. IO a -> a
readingSystem (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
file
        let dirExists :: Bool
dirExists = IO Bool -> Bool
forall a. IO a -> a
readingSystem (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
file

        let cfile :: String
cfile = IO String -> String
forall a. IO a -> a
readingSystem (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath String
file
        let isVirtual :: Bool
isVirtual = [Bool] -> Bool
forall t. (Container t, Element t ~ Bool) => t -> Bool
or
                [ Pattern -> String -> Bool
Glob.match Pattern
pat String
cfile
                | RelGlobPattern
virtualFile <- [RelGlobPattern]
vcVirtualFiles
                , let pat :: Pattern
pat = String -> RelGlobPattern -> Pattern
bindGlobPattern String
root RelGlobPattern
virtualFile ]

        Bool -> ExceptT VerifyError IO () -> ExceptT VerifyError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
fileExists Bool -> Bool -> Bool
|| Bool
dirExists Bool -> Bool -> Bool
|| Bool
isVirtual) (ExceptT VerifyError IO () -> ExceptT VerifyError IO ())
-> ExceptT VerifyError IO () -> ExceptT VerifyError IO ()
forall a b. (a -> b) -> a -> b
$
            VerifyError -> ExceptT VerifyError IO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> VerifyError
FileDoesNotExist String
file)

    checkAnchor :: String -> [Anchor] -> Text -> ExceptT VerifyError IO ()
checkAnchor String
file [Anchor]
fileAnchors Text
anchor = do
        String -> [Anchor] -> Text -> ExceptT VerifyError IO ()
forall (f :: * -> *).
MonadError VerifyError f =>
String -> [Anchor] -> Text -> f ()
checkAnchorReferenceAmbiguity String
file [Anchor]
fileAnchors Text
anchor
        String -> [Anchor] -> Text -> ExceptT VerifyError IO ()
forall (f :: * -> *).
MonadError VerifyError f =>
String -> [Anchor] -> Text -> f ()
checkDeduplicatedAnchorReference String
file [Anchor]
fileAnchors Text
anchor
        [Anchor] -> Text -> ExceptT VerifyError IO ()
checkAnchorExists [Anchor]
fileAnchors Text
anchor

    -- 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 :: String -> [Anchor] -> Text -> f ()
checkAnchorReferenceAmbiguity String
file [Anchor]
fileAnchors Text
anchor = do
        let similarAnchors :: [Anchor]
similarAnchors = (Anchor -> Bool) -> [Anchor] -> [Anchor]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
anchor) (Text -> Bool) -> (Anchor -> Text) -> Anchor -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anchor -> Text
aName) [Anchor]
fileAnchors
        Bool -> f () -> f ()
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) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$
            VerifyError -> f ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerifyError -> f ()) -> VerifyError -> f ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> NonEmpty Anchor -> VerifyError
AmbiguousAnchorRef String
file 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 :: String -> [Anchor] -> Text -> f ()
checkDeduplicatedAnchorReference String
file [Anchor]
fileAnchors Text
anchor =
        Maybe Text -> (Text -> f ()) -> f ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust (Text -> Maybe Text
stripAnchorDupNo Text
anchor) ((Text -> f ()) -> f ()) -> (Text -> f ()) -> f ()
forall a b. (a -> b) -> a -> b
$ \Text
origAnchor ->
            String -> [Anchor] -> Text -> f ()
forall (f :: * -> *).
MonadError VerifyError f =>
String -> [Anchor] -> Text -> f ()
checkAnchorReferenceAmbiguity String
file [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
forall a. Eq a => a -> a -> Bool
== 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
>= Double
vcAnchorSimilarityThreshold)
                    similarAnchors :: [Anchor]
similarAnchors =
                        (Anchor -> Bool) -> [Anchor] -> [Anchor]
forall a. (a -> Bool) -> [a] -> [a]
filter (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
damerauLevenshteinNorm Text
anchor (Text -> Ratio Int) -> (Anchor -> Text) -> Anchor -> Ratio Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anchor -> Text
aName)
                        [Anchor]
givenAnchors
                in VerifyError -> ExceptT VerifyError IO ()
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 :: VerifyConfig
                      -> Text
                      -> IO (VerifyResult VerifyError)
checkExternalResource :: VerifyConfig -> Text -> IO (VerifyResult VerifyError)
checkExternalResource VerifyConfig{Double
[String]
[RelGlobPattern]
Maybe [Regex]
Time Second
vcIgnoreRefs :: Maybe [Regex]
vcNotScanned :: [String]
vcVirtualFiles :: [RelGlobPattern]
vcExternalRefCheckTimeout :: Time Second
vcAnchorSimilarityThreshold :: Double
vcIgnoreRefs :: VerifyConfig -> Maybe [Regex]
vcNotScanned :: VerifyConfig -> [String]
vcVirtualFiles :: VerifyConfig -> [RelGlobPattern]
vcExternalRefCheckTimeout :: VerifyConfig -> Time Second
vcAnchorSimilarityThreshold :: VerifyConfig -> Double
..} Text
link
    | Bool
isIgnored = VerifyResult VerifyError -> IO (VerifyResult VerifyError)
forall (m :: * -> *) a. Monad m => a -> m a
return VerifyResult VerifyError
forall a. Monoid a => a
mempty
    | Bool
doesReferLocalhost = VerifyResult VerifyError -> IO (VerifyResult VerifyError)
forall (m :: * -> *) a. Monad m => a -> m a
return VerifyResult VerifyError
forall a. Monoid a => a
mempty
    | Bool
otherwise = (Either VerifyError () -> VerifyResult VerifyError)
-> IO (Either VerifyError ()) -> IO (VerifyResult VerifyError)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either VerifyError () -> VerifyResult VerifyError
forall e. Either e () -> VerifyResult e
toVerifyRes (IO (Either VerifyError ()) -> IO (VerifyResult VerifyError))
-> IO (Either VerifyError ()) -> IO (VerifyResult VerifyError)
forall a b. (a -> b) -> a -> b
$ do
        HEAD -> RatioNat -> IO (Either VerifyError ())
forall method.
(HttpBodyAllowed (AllowsBody method) 'NoBody, HttpMethod method) =>
method -> RatioNat -> IO (Either VerifyError ())
makeRequest HEAD
HEAD RatioNat
0.3 IO (Either VerifyError ())
-> (Either VerifyError () -> IO (Either VerifyError ()))
-> IO (Either VerifyError ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Right () -> Either VerifyError () -> IO (Either VerifyError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either VerifyError () -> IO (Either VerifyError ()))
-> Either VerifyError () -> IO (Either VerifyError ())
forall a b. (a -> b) -> a -> b
$ () -> Either VerifyError ()
forall a b. b -> Either a b
Right ()
            Left   VerifyError
_ -> GET -> RatioNat -> IO (Either VerifyError ())
forall method.
(HttpBodyAllowed (AllowsBody method) 'NoBody, HttpMethod method) =>
method -> RatioNat -> IO (Either VerifyError ())
makeRequest GET
GET RatioNat
0.7
  where
    isIgnored :: Bool
isIgnored =
        let maybeIsIgnored :: Maybe Bool
maybeIsIgnored = (Text -> [Regex] -> Bool
doesMatchAnyRegex Text
link) ([Regex] -> Bool) -> Maybe [Regex] -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Regex]
vcIgnoreRefs
        in Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
maybeIsIgnored
    doesReferLocalhost :: Bool
doesReferLocalhost = (Element [Text] -> Bool) -> [Text] -> Bool
forall t. Container t => (Element t -> Bool) -> t -> Bool
any (Text -> Text -> Bool
`T.isInfixOf` Text
link) [Text
"://localhost", Text
"://127.0.0.1"]

    doesMatchAnyRegex :: Text -> ([Regex] -> Bool)
    doesMatchAnyRegex :: Text -> [Regex] -> Bool
doesMatchAnyRegex Text
src = (Element [Regex] -> Bool) -> [Regex] -> Bool
forall t. Container t => (Element t -> Bool) -> t -> Bool
any ((Element [Regex] -> Bool) -> [Regex] -> Bool)
-> (Element [Regex] -> Bool) -> [Regex] -> Bool
forall a b. (a -> b) -> a -> b
$ \Element [Regex]
regex ->
        case Regex -> Text -> Either String (Maybe (Text, Text, Text, [Text]))
regexec Regex
Element [Regex]
regex Text
src of
            Right Maybe (Text, Text, Text, [Text])
res -> case Maybe (Text, Text, Text, [Text])
res of
                Just (Text
before, Text
match, Text
after, [Text]
_) -> Text -> Bool
forall t. Container t => t -> Bool
null Text
before Bool -> Bool -> Bool
&& Text -> Bool
forall t. Container t => t -> Bool
null Text
after Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
forall t. Container t => t -> Bool
null Text
match)
                Maybe (Text, Text, Text, [Text])
Nothing -> Bool
False
            Left String
_ -> Bool
False

    makeRequest :: _ => method -> RatioNat -> IO (Either VerifyError ())
    makeRequest :: method -> RatioNat -> IO (Either VerifyError ())
makeRequest method
method RatioNat
timeoutFrac = 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
$ do
        URI
uri <- Text -> Maybe URI
forall (m :: * -> *). MonadThrow m => Text -> m URI
mkURI Text
link
             Maybe URI
-> (Maybe URI -> ExceptT VerifyError IO URI)
-> ExceptT VerifyError IO URI
forall a b. a -> (a -> b) -> b
& ExceptT VerifyError IO URI
-> (URI -> ExceptT VerifyError IO URI)
-> Maybe URI
-> ExceptT VerifyError IO URI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (VerifyError -> ExceptT VerifyError IO URI
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError VerifyError
ExternalResourceInvalidUri) URI -> ExceptT VerifyError IO URI
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
parsedUrl <- 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
                   Maybe
  (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
-> (Maybe
      (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
    -> ExceptT
         VerifyError
         IO
         (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)))
-> ExceptT
     VerifyError
     IO
     (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
forall a b. a -> (a -> b) -> b
& ExceptT
  VerifyError
  IO
  (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
-> (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
    -> ExceptT
         VerifyError
         IO
         (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)))
-> Maybe
     (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
-> ExceptT
     VerifyError
     IO
     (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (VerifyError
-> ExceptT
     VerifyError
     IO
     (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError VerifyError
ExternalResourceUnknownProtocol) Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
-> ExceptT
     VerifyError
     IO
     (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        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
defaultHttpConfig (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
defaultHttpConfig (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 = RatioNat -> Time Second
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)
Time Second
vcExternalRefCheckTimeout RatioNat -> RatioNat -> RatioNat
forall a. Num a => a -> a -> a
* RatioNat
timeoutFrac

        Maybe ()
mres <- IO (Maybe ()) -> ExceptT VerifyError IO (Maybe ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Time (1 :% 1) -> IO () -> IO (Maybe ())
forall (unit :: Rat) (m :: * -> *) a.
(MonadIO m, KnownDivRat unit Microsecond) =>
Time unit -> IO a -> m (Maybe a)
timeout Time (1 :% 1)
Time Second
maxTime (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ IO IgnoreResponse -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO IgnoreResponse
reqLink)
                ExceptT VerifyError IO (Maybe ())
-> (HttpException -> ExceptT VerifyError IO (Maybe ()))
-> ExceptT VerifyError IO (Maybe ())
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` ((VerifyError -> ExceptT VerifyError IO (Maybe ()))
-> (() -> ExceptT VerifyError IO (Maybe ()))
-> Either VerifyError ()
-> ExceptT VerifyError IO (Maybe ())
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either VerifyError -> ExceptT VerifyError IO (Maybe ())
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (\() -> Maybe () -> ExceptT VerifyError IO (Maybe ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Maybe ()
forall a. a -> Maybe a
Just ())) (Either VerifyError () -> ExceptT VerifyError IO (Maybe ()))
-> (HttpException -> Either VerifyError ())
-> HttpException
-> ExceptT VerifyError IO (Maybe ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> Either VerifyError ()
interpretErrors)
        ExceptT VerifyError IO ()
-> (() -> ExceptT VerifyError IO ())
-> Maybe ()
-> ExceptT VerifyError IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (VerifyError -> ExceptT VerifyError IO ()
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 -> VerifyError
ExternalResourceSomeError Text
"Response timeout") () -> ExceptT VerifyError IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ()
mres

    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)
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.
        [ (Int
403 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==)  -- unauthorized access
        , (Int
405 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==)  -- method mismatch
        ]

    interpretErrors :: HttpException -> Either VerifyError ()
interpretErrors = \case
        JsonHttpException String
_ -> Text -> Either VerifyError ()
forall a. HasCallStack => Text -> a
error Text
"External link JSON parse exception"
        VanillaHttpException HttpException
err -> case HttpException
err of
            InvalidUrlException{} -> Text -> Either VerifyError ()
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
isAllowedErrorCode (Status -> Int
statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response () -> Status
forall body. Response body -> Status
responseStatus Response ()
resp) -> () -> Either VerifyError ()
forall a b. b -> Either a b
Right ()
                    | Bool
otherwise -> VerifyError -> Either VerifyError ()
forall a b. a -> Either a b
Left (VerifyError -> Either VerifyError ())
-> VerifyError -> Either VerifyError ()
forall a b. (a -> b) -> a -> b
$ Status -> VerifyError
ExternalResourceUnavailable (Response () -> Status
forall body. Response body -> Status
responseStatus Response ()
resp)
                HttpExceptionContent
other -> VerifyError -> Either VerifyError ()
forall a b. a -> Either a b
Left (VerifyError -> Either VerifyError ())
-> (Text -> VerifyError) -> Text -> Either VerifyError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> VerifyError
ExternalResourceSomeError (Text -> Either VerifyError ()) -> Text -> Either VerifyError ()
forall a b. (a -> b) -> a -> b
$ HttpExceptionContent -> Text
forall b a. (Show a, IsString b) => a -> b
show HttpExceptionContent
other