Allow to specify virtual files

For instance, reference to `issues` github page is a valid one despite there is no such
file physically in the repository.

Now user can specify list of "existing" virtual files in config.

.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/*

package.yaml

@@ -62,6 +62,7 @@ dependencies:
   - directory
   - filepath
   - fmt
+  - Glob
   - http-client
   - http-types
   - lens

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 = []
         }
 
 -----------------------------------------------------------

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 ()

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

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