[#55] Generate config depending on the repo type

Problem: now when we include repository type into the config, it seems
to make sense to generate config differently depending on the repository
type. Especially taking into account that currently in some fields we
mix GitHub and GitLab -specific contents.

Solution:

Leave placeholders in the default config and later fill them from the
code depending on the required repository type.

Add a mandatory repository type parameter to `dump-config` CLI command.

Along with a test checking for config validity, add a golden test on the
produced config so that we could assess how sane it looks like.

Author: Martoon-00

README.md

@@ -153,7 +153,7 @@ xrefcheck --help
 Configuration template (with all options explained) can be dumped with:
 
 ```sh
-xrefcheck dump-config
+xrefcheck dump-config -t GitHub
 ```
 
 Currently supported options include:

exec/Main.hs

@@ -13,6 +13,7 @@ import System.Directory (doesFileExist)
 
 import Xrefcheck.CLI
 import Xrefcheck.Config
+import Xrefcheck.Core
 import Xrefcheck.Progress
 import Xrefcheck.Scan
 import Xrefcheck.Scanners
@@ -33,8 +34,10 @@ defaultAction Options{..} = do
         mConfigPath <- findFirstExistingFile defaultConfigPaths
         case mConfigPath of
           Nothing -> do
-            hPutStrLn @Text stderr "Configuration file not found, using default config\n"
-            pure defConfig
+            hPutStrLn @Text stderr
+              "Configuration file not found, using default config \
+              \for GitHub repositories\n"
+            pure $ defConfig GitHub
           Just configPath ->
             readConfig configPath
       Just configPath -> do
@@ -79,5 +82,5 @@ main = withUtf8 $ do
     case command of
       DefaultCommand options ->
         defaultAction options
-      DumpConfig path ->
-        BS.writeFile path defConfigText
+      DumpConfig repoType path ->
+        BS.writeFile path (defConfigText repoType)

package.yaml

@@ -83,6 +83,7 @@ dependencies:
   - optparse-applicative
   - regex-tdfa
   - req
+  - regex-tdfa
   - roman-numerals
   - template-haskell
   - text

src-files/def-config.yaml

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>
+# SPDX-FileCopyrightText: 2019-2021 Serokell <https://serokell.io>
 #
 # SPDX-License-Identifier: Unlicense
 
@@ -26,30 +26,12 @@ verification:
 
   # Prefixes of files, references in which should not be analyzed.
   notScanned:
-    # GitHub-specific files
-    - .github/pull_request_template.md
-    - .github/issue_template.md
-    - .github/PULL_REQUEST_TEMPLATE
-    - .github/ISSUE_TEMPLATE
-
-    # GitLab-specific files
-    - .gitlab/merge_request_templates/
-    - .gitlab/issue_templates/
+    - :PLACEHOLDER:notScanned:
 
   # 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/*
-
-    # GitLab pages
-    - ../../issues
-    - ../../issues/*
-    - ../../merge_requests
-    - ../../merge_requests/*
+    - :PLACEHOLDER:virtualFiles:
 
   # POSIX extended regular expressions that match external references
   # that have to be ignored (not verified).
@@ -64,4 +46,4 @@ scanners:
     # Flavor of markdown, e.g. GitHub-flavor.
     #
     # This affects which anchors are generated for headers.
-    flavor: GitHub
+    flavor: :PLACEHOLDER:flavor:

src/Xrefcheck/CLI.hs

@@ -17,7 +17,9 @@ module Xrefcheck.CLI
     , getCommand
     ) where
 
+import qualified Data.Char as C
 import qualified Data.List as L
+import qualified Data.Text as T
 import Data.Version (showVersion)
 import Options.Applicative
   (Parser, ReadM, command, eitherReader, execParser, flag', footerDoc, fullDesc, help, helper,
@@ -45,7 +47,7 @@ modeReadM = eitherReader $ \s ->
 
 data Command
   = DefaultCommand Options
-  | DumpConfig FilePath
+  | DumpConfig Flavor FilePath
 
 data Options = Options
     { oConfigPath       :: Maybe FilePath
@@ -71,6 +73,24 @@ addTraversalOptions TraversalConfig{..} (TraversalOptions ignored) =
 defaultConfigPaths :: [FilePath]
 defaultConfigPaths = ["./xrefcheck.yaml", "./.xrefcheck.yaml"]
 
+-- | Strictly speaking, what config we will dump depends on the repository type:
+-- this affects Markdown flavor, things excluded by default, e.t.c.
+--
+-- But at the moment there is one-to-one correspondence between repository types
+-- and flavors, so we write a type alias here.
+type RepoType = Flavor
+
+repoTypeReadM :: ReadM RepoType
+repoTypeReadM = eitherReader $ \name ->
+  maybeToRight (failureText name) $ L.lookup (map C.toLower name) allRepoTypesNamed
+  where
+    allRepoTypesNamed =
+      allRepoTypes <&> \ty -> (toString $ T.toLower (show ty), ty)
+    failureText name =
+      "Unknown repository type: " <> show name <> "\n\
+      \Expected one of: " <> mconcat (intersperse ", " $ map show allRepoTypes)
+    allRepoTypes = allFlavors
+
 optionsParser :: Parser Options
 optionsParser = do
     oConfigPath <- optional . strOption $
@@ -122,13 +142,23 @@ traversalOptionsParser = do
         help "Files and folders which we pretend do not exist."
     return TraversalOptions{..}
 
-dumpConfigOptions :: Parser FilePath
+dumpConfigOptions :: Parser Command
 dumpConfigOptions = hsubparser $
   command "dump-config" $
     info parser $
     progDesc "Dump default configuration into a file."
   where
-    parser = strOption $
+    parser = DumpConfig <$> repoTypeOption <*> outputOption
+
+    repoTypeOption =
+      option repoTypeReadM $
+      short 't' <>
+      long "type" <>
+      metavar "REPOSITORY TYPE" <>
+      help "Git repository type."
+
+    outputOption =
+      strOption $
       short 'o' <>
       long "output" <>
       metavar "FILEPATH" <>
@@ -138,7 +168,7 @@ dumpConfigOptions = hsubparser $
 totalParser :: Parser Command
 totalParser = asum
   [ DefaultCommand <$> optionsParser
-  , DumpConfig <$> dumpConfigOptions
+  , dumpConfigOptions
   ]
 
 versionOption :: Parser (a -> a)

src/Xrefcheck/Config.hs

@@ -7,23 +7,31 @@
 
 module Xrefcheck.Config where
 
+import qualified Unsafe
+
+import Control.Exception (assert)
 import Control.Lens (makeLensesWith)
 import Data.Aeson.TH (deriveFromJSON)
+import qualified Data.ByteString as BS
+import qualified Data.Map as Map
 import Data.Yaml (FromJSON (..), decodeEither', prettyPrintParseException, withText)
 import Instances.TH.Lift ()
 import Text.Regex.TDFA (CompOption (..), ExecOption (..), Regex)
-import Text.Regex.TDFA.Text (compile)
+import qualified Text.Regex.TDFA as R
+import Text.Regex.TDFA.ByteString ()
+import qualified Text.Regex.TDFA.Text as R
 
 -- FIXME: Use </> from System.FilePath
 -- </> from Posix is used only because we cross-compile to Windows and \ doesn't work on Linux
 import Data.FileEmbed (embedFile)
 import System.FilePath.Posix ((</>))
 import Time (KnownRatName, Second, Time, unitsP)
 
+import Xrefcheck.Core
 import Xrefcheck.Scan
 import Xrefcheck.Scanners.Markdown
 import Xrefcheck.System (RelGlobPattern)
-import Xrefcheck.Util (aesonConfigOption, postfixFields)
+import Xrefcheck.Util (aesonConfigOption, postfixFields, (-:))
 
 -- | Overall config.
 data Config = Config
@@ -56,18 +64,119 @@ makeLensesWith postfixFields ''VerifyConfig
 -- Default config
 -----------------------------------------------------------
 
+defConfigUnfilled :: ByteString
+defConfigUnfilled =
+  $(embedFile ("src-files" </> "def-config.yaml"))
+
+-- | Picks raw config with @:PLACEHOLDER:<key>:@ and fills the specified fields
+-- in it, picking a replacement suitable for the given key. Only strings and lists
+-- of strings can be filled this way.
+--
+-- This will fail if any placeholder is left unreplaced, however extra keys in
+-- the provided replacement won't cause any warnings or failures.
+fillHoles
+  :: HasCallStack
+  => [(ByteString, Either ByteString [ByteString])] -> ByteString -> ByteString
+fillHoles allReplacements rawConfig =
+  let holesLocs = R.getAllMatches $ holeLineRegex `R.match` rawConfig
+  in mconcat $ replaceHoles 0 holesLocs
+  where
+    showBs :: ByteString -> Text
+    showBs = show @_ @Text . decodeUtf8
+
+    holeLineRegex :: R.Regex
+    holeLineRegex = R.makeRegex ("[ -]+:PLACEHOLDER:[^:]+:" :: Text)
+
+    replacementsMap = Map.fromList allReplacements
+    getReplacement key =
+      Map.lookup key replacementsMap
+      ?: error ("Replacement for key " <> showBs key <> " is not specified")
+
+    pickConfigSubstring :: Int -> Int -> ByteString
+    pickConfigSubstring from len = BS.take len $ BS.drop from rawConfig
+
+    replaceHoles :: Int -> [(R.MatchOffset, R.MatchLength)] -> [ByteString]
+    replaceHoles processedLen [] = one $ BS.drop processedLen rawConfig
+    replaceHoles processedLen ((off, len) : locs) =
+      -- in our case matches here should not overlap
+      assert (off > processedLen) $
+        pickConfigSubstring processedLen (off - processedLen) :
+        replaceHole (pickConfigSubstring off len) ++
+        replaceHoles (off + len) locs
+
+    holeItemRegex :: R.Regex
+    holeItemRegex = R.makeRegex ("(^|:)([ ]*):PLACEHOLDER:([^:]+):" :: Text)
+
+    holeListRegex :: R.Regex
+    holeListRegex = R.makeRegex ("^([ ]*-[ ]*):PLACEHOLDER:([^:]+):" :: Text)
+
+    replaceHole :: ByteString -> [ByteString]
+    replaceHole holeLine = if
+      | Just [_wholeMatch, _beginning, leadingSpaces, key] <-
+        R.getAllTextSubmatches <$> (holeItemRegex `R.matchM` holeLine) ->
+          case getReplacement key of
+            Left replacement -> [leadingSpaces, replacement]
+            Right _ -> error $
+              "Key " <> showBs key <> " requires replacement with an item, \
+              \but list was given"
+
+      | Just [_wholeMatch, leadingChars, key] <-
+        R.getAllTextSubmatches <$> (holeListRegex `R.matchM` holeLine) ->
+          case getReplacement key of
+            Left _ -> error $
+              "Key " <> showBs key <> " requires replacement with a list, \
+              \but an item was given"
+            Right [] ->
+              ["[]"]
+            Right replacements@(_ : _) ->
+              Unsafe.init $ do
+                replacement <- replacements
+                [leadingChars, replacement, "\n"]
+
+      | otherwise ->
+          error $ "Unrecognized placeholder pattern " <> showBs holeLine
+
 -- | Default config in textual representation.
 --
 -- Sometimes you cannot just use 'defConfig' because clarifying comments
 -- would be lost.
-defConfigText :: ByteString
-defConfigText =
-  $(embedFile ("src-files" </> "def-config.yaml"))
-
-defConfig :: HasCallStack => Config
-defConfig =
+defConfigText :: Flavor -> ByteString
+defConfigText flavor =
+  flip fillHoles defConfigUnfilled
+    [
+      "flavor" -: Left (show flavor)
+
+    , "notScanned" -: Right $ case flavor of
+        GitHub ->
+          [ ".github/pull_request_template.md"
+          , ".github/issue_template.md"
+          , ".github/PULL_REQUEST_TEMPLATE"
+          , ".github/ISSUE_TEMPLATE"
+          ]
+        GitLab ->
+          [ ".gitlab/merge_request_templates/"
+          , ".gitlab/issue_templates/"
+          ]
+
+    , "virtualFiles" -: Right $ case flavor of
+        GitHub ->
+          [ "../../../issues"
+          , "../../../issues/*"
+          , "../../../pulls"
+          , "../../../pulls/*"
+          ]
+        GitLab ->
+          [ "../../issues"
+          , "../../issues/*"
+          , "../../merge_requests"
+          , "../../merge_requests/*"
+          ]
+    ]
+
+defConfig :: HasCallStack => Flavor -> Config
+defConfig flavor =
   either (error . toText . prettyPrintParseException) id $
-  decodeEither' defConfigText
+  decodeEither' (defConfigText flavor)
 
 -----------------------------------------------------------
 -- Yaml instances
@@ -84,7 +193,7 @@ instance KnownRatName unit => FromJSON (Time unit) where
 instance FromJSON Regex where
     parseJSON = withText "regex" $ \val -> do
         let errOrRegex =
-                compile defaultCompOption defaultExecOption val
+                R.compile defaultCompOption defaultExecOption val
         either (error . show) return errOrRegex
 
 -- Default boolean values according to

src/Xrefcheck/Core.hs

@@ -38,6 +38,14 @@ data Flavor
   | GitLab
   deriving (Show)
 
+allFlavors :: [Flavor]
+allFlavors = [GitHub, GitLab]
+  where
+    _exhaustivenessCheck = \case
+      GitHub -> ()
+      GitLab -> ()
+      -- if you update this, also update the list above
+
 instance FromJSON Flavor where
   parseJSON = withText "flavor" $ \txt ->
     case T.toLower txt of

src/Xrefcheck/Util.hs

@@ -9,6 +9,7 @@ module Xrefcheck.Util
     ( nameF'
     , paren
     , postfixFields
+    , (-:)
     , aesonConfigOption
     ) where
 
@@ -33,6 +34,10 @@ paren a
 postfixFields :: LensRules
 postfixFields = lensRules & lensField .~ mappingNamer (\n -> [n ++ "L"])
 
+infixr 0 -:
+(-:) :: a -> b -> (a, b)
+(-:) = (,)
+
 -- | Options that we use to derive JSON instances for config types.
 aesonConfigOption :: Aeson.Options
 aesonConfigOption = aesonPrefix camelCase