diff --git a/.crossref-verifier.yaml b/.crossref-verifier.yaml index 15d7bd8..b574b99 100644 --- a/.crossref-verifier.yaml +++ b/.crossref-verifier.yaml @@ -2,15 +2,28 @@ traversal: # Full paths which should be excluded from consideration. excluded: + # Stack files - .stack-work + + # Github-specific files - .github/pull_request_template.md - docs/pull_request_template.md -# Parameters of verification. +# Verification parameters. verification: # On 'anchor not found' error, how much similar anchors should be displayed as hint. # Number should be between 0 and 1, larger value means stricter filter. anchorSimilarityThreshold: 0.5 + # When checking external references, how long to wait on request before # declaring "Response timeout". externalRefCheckTimeout: 10s + + # Glob patterns describing the files which do not physically exist in the repository + # but should be treated as existing nevertheless. + virtualFiles: + # Github pages + - ../../issues + - ../../issues/* + - ../../pulls + - ../../pulls/* diff --git a/package.yaml b/package.yaml index 22ca27a..65621f1 100644 --- a/package.yaml +++ b/package.yaml @@ -62,6 +62,7 @@ dependencies: - directory - filepath - fmt + - Glob - http-client - http-types - lens diff --git a/src/Crv/Config.hs b/src/Crv/Config.hs index c17b032..30a0516 100644 --- a/src/Crv/Config.hs +++ b/src/Crv/Config.hs @@ -8,6 +8,8 @@ import Data.Aeson.TH (deriveFromJSON) import Data.Default (Default (..)) import Time (KnownRatName, Second, Time, sec, unitsP) +import Crv.System (CanonicalizedGlobPattern) + -- | Overall config. data Config = Config { cTraversal :: TraversalConfig @@ -23,6 +25,7 @@ data TraversalConfig = TraversalConfig data VerifyConfig = VerifyConfig { vcAnchorSimilarityThreshold :: Double , vcExternalRefCheckTimeout :: Time Second + , vcVirtualFiles :: [CanonicalizedGlobPattern] } ----------------------------------------------------------- @@ -44,6 +47,7 @@ instance Default VerifyConfig where VerifyConfig { vcAnchorSimilarityThreshold = 0.5 , vcExternalRefCheckTimeout = sec 3 + , vcVirtualFiles = [] } ----------------------------------------------------------- diff --git a/src/Crv/Progress.hs b/src/Crv/Progress.hs index 902e74c..03f27d2 100644 --- a/src/Crv/Progress.hs +++ b/src/Crv/Progress.hs @@ -92,7 +92,7 @@ allowRewrite action = maxPrintedSize <- readIORef rMaxPrintedSize hPutStr stderr $ '\r' : replicate maxPrintedSize ' ' ++ "\r" -- prevent our output to interleave with further outputs - threadDelay (ms 70) + threadDelay (ms 100) -- | Return caret and print the given text. putTextRewrite :: MonadIO m => Rewrite -> Text -> m () diff --git a/src/Crv/System.hs b/src/Crv/System.hs new file mode 100644 index 0000000..29f9b3b --- /dev/null +++ b/src/Crv/System.hs @@ -0,0 +1,24 @@ +module Crv.System + ( readingSystem + , CanonicalizedGlobPattern (..) + ) where + +import Data.Aeson (FromJSON (..), withText) +import GHC.IO.Unsafe (unsafePerformIO) +import System.Directory (canonicalizePath) +import qualified System.FilePath.Glob as Glob + +-- | We can quite safely treat surrounding filesystem as frozen, +-- so IO reading operations can be turned into pure values. +readingSystem :: IO a -> a +readingSystem = unsafePerformIO + +-- | Glob pattern with 'canonicalizePath' applied O_o. +newtype CanonicalizedGlobPattern = CanonicalizedGlobPattern Glob.Pattern + +instance FromJSON CanonicalizedGlobPattern where + parseJSON = withText "Repo-rooted glob pattern" $ \path -> do + let !cpath = readingSystem $ canonicalizePath (toString path) + cpat <- Glob.tryCompileWith Glob.compDefault cpath + & either fail pure + return $ CanonicalizedGlobPattern cpat diff --git a/src/Crv/Verify.hs b/src/Crv/Verify.hs index 8c69699..4aed735 100644 --- a/src/Crv/Verify.hs +++ b/src/Crv/Verify.hs @@ -29,7 +29,8 @@ import Network.HTTP.Req (GET (..), HEAD (..), HttpException (..), NoReqBody (..) parseUrl, req, runReq) import Network.HTTP.Types.Status (Status, statusCode, statusMessage) import System.Console.Pretty (Style (..), style) -import System.Directory (doesDirectoryExist, doesFileExist) +import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist) +import qualified System.FilePath.Glob as Glob import System.FilePath.Posix (takeDirectory) import System.FilePath.Posix (()) import Time (RatioNat, Second, Time (..), ms, threadDelay, timeout) @@ -37,6 +38,7 @@ import Time (RatioNat, Second, Time (..), ms, threadDelay, timeout) import Crv.Config import Crv.Core import Crv.Progress +import Crv.System ----------------------------------------------------------- -- General verification @@ -148,10 +150,10 @@ verifyReference config@VerifyConfig{..} mode progressRef (RepoInfo repoInfo) if shouldCheckLocType mode locType then do res <- case locType of - LocalLoc -> checkFileRef rAnchor containingFile - RelativeLoc -> checkFileRef rAnchor + LocalLoc -> checkRef rAnchor containingFile + RelativeLoc -> checkRef rAnchor (takeDirectory containingFile toString rLink) - AbsoluteLoc -> checkFileRef rAnchor (root <> toString rLink) + AbsoluteLoc -> checkRef rAnchor (root <> toString rLink) ExternalLoc -> checkExternalResource config rLink OtherLoc -> verifying pass @@ -168,17 +170,25 @@ verifyReference config@VerifyConfig{..} mode progressRef (RepoInfo repoInfo) return $ fmap (WithReferenceLoc containingFile ref) res else return mempty where - checkFileRef mAnchor file = verifying $ do - fileExists <- liftIO $ doesFileExist file - dirExists <- liftIO $ doesDirectoryExist file - unless (fileExists || dirExists) $ - throwError (FileDoesNotExist file) - + checkRef mAnchor file = verifying $ do + checkReferredFileExists file case M.lookup file repoInfo of Nothing -> pass -- no support for such file, can do nothing Just referedFileInfo -> whenJust mAnchor $ checkAnchorExists (_fiAnchors referedFileInfo) + checkReferredFileExists file = do + let fileExists = readingSystem $ doesFileExist file + let dirExists = readingSystem $ doesDirectoryExist file + + let cfile = readingSystem $ canonicalizePath file + let isVirtual = or + [ Glob.match pat cfile + | CanonicalizedGlobPattern pat <- vcVirtualFiles ] + + unless (fileExists || dirExists || isVirtual) $ + throwError (FileDoesNotExist file) + checkAnchorExists givenAnchors anchor = case find ((== anchor) . aName) givenAnchors of Just _ -> pass