{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
module Xrefcheck.Verify
(
VerifyResult (..)
, verifyOk
, verifyErrors
, verifying
, WithReferenceLoc (..)
, 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) #-}
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 (\() -> [])
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
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
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)
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
[ (Int
403 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==)
, (Int
405 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==)
]
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