mirror of
https://github.com/serokell/xrefcheck.git
synced 2024-09-11 13:37:36 +03:00
Merge pull request #225 from serokell/Sorokin-Anton/#223-nyan-defConfigText
[#223] Use nyan-interpolation for `defConfigText`
This commit is contained in:
commit
a2404e8c2f
@ -7,7 +7,6 @@ module Main where
|
||||
|
||||
import Universum
|
||||
|
||||
import Data.ByteString qualified as BS
|
||||
import Main.Utf8 (withUtf8)
|
||||
|
||||
import Xrefcheck.CLI (Command (..), getCommand)
|
||||
@ -21,4 +20,4 @@ main = withUtf8 $ do
|
||||
DefaultCommand options ->
|
||||
defaultAction options
|
||||
DumpConfig repoType path ->
|
||||
BS.writeFile path (defConfigText repoType)
|
||||
writeFile path (defConfigText repoType)
|
||||
|
@ -86,7 +86,6 @@ library:
|
||||
- directory
|
||||
- dlist
|
||||
- filepath
|
||||
- raw-strings-qq
|
||||
- fmt
|
||||
- ftp-client
|
||||
- Glob
|
||||
@ -104,7 +103,6 @@ library:
|
||||
- tagsoup
|
||||
- text
|
||||
- text-metrics
|
||||
- th-lift-instances
|
||||
- time
|
||||
- transformers
|
||||
- universum
|
||||
@ -127,7 +125,6 @@ executables:
|
||||
- -O2
|
||||
dependencies:
|
||||
- xrefcheck
|
||||
- bytestring
|
||||
- universum
|
||||
- with-utf8
|
||||
|
||||
@ -144,7 +141,6 @@ tests:
|
||||
- cmark-gfm
|
||||
- firefly
|
||||
- xrefcheck
|
||||
- bytestring
|
||||
- directory
|
||||
- http-types
|
||||
- o-clock
|
||||
|
@ -5,22 +5,17 @@
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Xrefcheck.Config where
|
||||
module Xrefcheck.Config
|
||||
( module Xrefcheck.Config
|
||||
, defConfigText
|
||||
) where
|
||||
|
||||
import Universum.Unsafe qualified as Unsafe
|
||||
|
||||
import Universum
|
||||
|
||||
import Control.Exception (assert)
|
||||
import Control.Lens (makeLensesWith)
|
||||
import Data.Aeson (genericParseJSON)
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.Map qualified as Map
|
||||
import Data.Yaml (FromJSON (..), decodeEither', prettyPrintParseException, withText)
|
||||
import Instances.TH.Lift ()
|
||||
import Text.Interpolation.Nyan
|
||||
import Text.Regex.TDFA qualified as R
|
||||
import Text.Regex.TDFA.ByteString ()
|
||||
|
||||
import Time (KnownRatName, Second, Time (..), unitsP)
|
||||
|
||||
@ -28,7 +23,7 @@ import Xrefcheck.Config.Default
|
||||
import Xrefcheck.Core
|
||||
import Xrefcheck.Scan
|
||||
import Xrefcheck.Scanners.Markdown
|
||||
import Xrefcheck.Util (Field, aesonConfigOption, postfixFields, (-:))
|
||||
import Xrefcheck.Util (Field, aesonConfigOption, postfixFields)
|
||||
|
||||
-- | Type alias for Config' with all required fields.
|
||||
type Config = Config' Identity
|
||||
@ -83,121 +78,10 @@ data ScannersConfig' f = ScannersConfig
|
||||
makeLensesWith postfixFields ''Config'
|
||||
makeLensesWith postfixFields ''NetworkingConfig'
|
||||
|
||||
-- | 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 $
|
||||
[int||
|
||||
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 $
|
||||
[int||
|
||||
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 :: Flavor -> ByteString
|
||||
defConfigText flavor =
|
||||
flip fillHoles defConfigUnfilled
|
||||
[
|
||||
"flavor" -: Left (show flavor)
|
||||
|
||||
, "ignoreRefsFrom" -: 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/**/*"
|
||||
]
|
||||
|
||||
, "ignoreLocalRefsTo" -: Right $ case flavor of
|
||||
GitHub ->
|
||||
[ "../../../issues"
|
||||
, "../../../issues/*"
|
||||
, "../../../pulls"
|
||||
, "../../../pulls/*"
|
||||
]
|
||||
GitLab ->
|
||||
[ "../../issues"
|
||||
, "../../issues/*"
|
||||
, "../../merge_requests"
|
||||
, "../../merge_requests/*"
|
||||
]
|
||||
]
|
||||
|
||||
defConfig :: HasCallStack => Flavor -> Config
|
||||
defConfig flavor = normaliseConfigFilePaths $
|
||||
either (error . toText . prettyPrintParseException) id $
|
||||
decodeEither' (defConfigText flavor)
|
||||
decodeEither' $ encodeUtf8 $ defConfigText flavor
|
||||
|
||||
-- | Override missed fields with default values.
|
||||
overrideConfig :: ConfigOptional -> Config
|
||||
|
@ -7,11 +7,15 @@ module Xrefcheck.Config.Default where
|
||||
|
||||
import Universum
|
||||
|
||||
import Text.RawString.QQ
|
||||
import Text.Interpolation.Nyan
|
||||
|
||||
defConfigUnfilled :: ByteString
|
||||
defConfigUnfilled =
|
||||
[r|# Exclusion parameters.
|
||||
import Xrefcheck.Core
|
||||
import Xrefcheck.Util
|
||||
|
||||
defConfigText :: Flavor -> Text
|
||||
defConfigText flavor =
|
||||
[int|D|
|
||||
# Exclusion parameters.
|
||||
exclusions:
|
||||
# Ignore these files. References to them will fail verification,
|
||||
# and references from them will not be verified.
|
||||
@ -21,18 +25,18 @@ exclusions:
|
||||
# References from these files will not be verified.
|
||||
# List of glob patterns.
|
||||
ignoreRefsFrom:
|
||||
- :PLACEHOLDER:ignoreRefsFrom:
|
||||
#{interpolateIndentF 4 $ interpolateBlockListF $ ignoreLocalRefsFrom}
|
||||
|
||||
# References to these paths will not be verified.
|
||||
# List of glob patterns.
|
||||
ignoreLocalRefsTo:
|
||||
- :PLACEHOLDER:ignoreLocalRefsTo:
|
||||
#{interpolateIndentF 4 $ interpolateBlockListF $ ignoreLocalRefsTo}
|
||||
|
||||
# References to these URIs will not be verified.
|
||||
# List of POSIX extended regular expressions.
|
||||
ignoreExternalRefsTo:
|
||||
# Ignore localhost links by default
|
||||
- ^(https?|ftps?)://(localhost|127\.0\.0\.1).*
|
||||
- ^(https?|ftps?)://(localhost|127\\.0\\.0\\.1).*
|
||||
|
||||
# Networking parameters.
|
||||
networking:
|
||||
@ -62,5 +66,33 @@ scanners:
|
||||
# Flavor of markdown, e.g. GitHub-flavor.
|
||||
#
|
||||
# This affects which anchors are generated for headers.
|
||||
flavor: :PLACEHOLDER:flavor:
|
||||
flavor: #s{flavor}
|
||||
|]
|
||||
where
|
||||
ignoreLocalRefsFrom :: NonEmpty Text
|
||||
ignoreLocalRefsFrom = fromList $ 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/**/*"
|
||||
]
|
||||
|
||||
ignoreLocalRefsTo :: NonEmpty Text
|
||||
ignoreLocalRefsTo = fromList $ case flavor of
|
||||
GitHub ->
|
||||
[ "../../../issues"
|
||||
, "../../../issues/*"
|
||||
, "../../../pulls"
|
||||
, "../../../pulls/*"
|
||||
]
|
||||
GitLab ->
|
||||
[ "../../issues"
|
||||
, "../../issues/*"
|
||||
, "../../merge_requests"
|
||||
, "../../merge_requests/*"
|
||||
]
|
||||
|
@ -15,9 +15,9 @@ import Control.Lens (makeLenses)
|
||||
import Data.Aeson (FromJSON (..), withText)
|
||||
import Data.Char (isAlphaNum)
|
||||
import Data.Char qualified as C
|
||||
import Data.Default (Default (..))
|
||||
import Data.DList (DList)
|
||||
import Data.DList qualified as DList
|
||||
import Data.Default (Default (..))
|
||||
import Data.List qualified as L
|
||||
import Data.Reflection (Given)
|
||||
import Data.Text qualified as T
|
||||
|
@ -25,8 +25,8 @@ import Control.Lens (_Just, makeLenses, makeLensesFor, (.=))
|
||||
import Control.Monad.Trans.Writer.CPS (Writer, runWriter, tell)
|
||||
import Data.Aeson (FromJSON (..), genericParseJSON)
|
||||
import Data.ByteString.Lazy qualified as BSL
|
||||
import Data.Default (def)
|
||||
import Data.DList qualified as DList
|
||||
import Data.Default (def)
|
||||
import Data.Text qualified as T
|
||||
import Data.Text.Lazy qualified as LT
|
||||
import Fmt (Buildable (..), nameF)
|
||||
|
@ -33,7 +33,7 @@ module Xrefcheck.Verify
|
||||
|
||||
import Universum
|
||||
|
||||
import Control.Concurrent.Async (async, cancel, wait, withAsync, Async, poll)
|
||||
import Control.Concurrent.Async (Async, async, cancel, poll, wait, withAsync)
|
||||
import Control.Exception (AsyncException (..), throwIO)
|
||||
import Control.Monad.Except (MonadError (..))
|
||||
import Data.ByteString qualified as BS
|
||||
@ -65,6 +65,7 @@ import Text.URI (Authority (..), ParseExceptionBs, URI (..), mkURIBs)
|
||||
import Time (RatioNat, Second, Time (..), ms, sec, threadDelay, timeout, (+:+), (-:-))
|
||||
import URI.ByteString qualified as URIBS
|
||||
|
||||
import Control.Exception.Safe (handleAsync, handleJust)
|
||||
import Data.Bits (toIntegralSized)
|
||||
import Xrefcheck.Config
|
||||
import Xrefcheck.Core
|
||||
@ -73,7 +74,6 @@ import Xrefcheck.Progress
|
||||
import Xrefcheck.Scan
|
||||
import Xrefcheck.System
|
||||
import Xrefcheck.Util
|
||||
import Control.Exception.Safe (handleAsync, handleJust)
|
||||
|
||||
{-# ANN module ("HLint: ignore Use uncurry" :: Text) #-}
|
||||
{-# ANN module ("HLint: ignore Use 'runExceptT' from Universum" :: Text) #-}
|
||||
|
@ -10,7 +10,6 @@ import Universum
|
||||
import Control.Concurrent (forkIO, killThread)
|
||||
import Control.Exception qualified as E
|
||||
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.List (isInfixOf)
|
||||
import Data.Yaml (ParseException (..), decodeEither')
|
||||
import Network.HTTP.Types (Status (..))
|
||||
@ -38,7 +37,7 @@ test_config =
|
||||
-- The config we match against can be regenerated with
|
||||
-- stack exec xrefcheck -- dump-config -t GitHub -o tests/configs/github-config.yaml
|
||||
[ testCase "Config matches" $ do
|
||||
config <- BS.readFile "tests/configs/github-config.yaml"
|
||||
config <- readFile "tests/configs/github-config.yaml"
|
||||
when (config /= defConfigText GitHub) $
|
||||
assertFailure $ toString $ unwords
|
||||
[ "Config does not match the expected format."
|
||||
@ -76,7 +75,7 @@ test_config =
|
||||
]
|
||||
, testGroup "Config parser reject input with unknown fields"
|
||||
[ testCase "throws error with useful messages" $ do
|
||||
case decodeEither' @Config (defConfigText GitHub <> "strangeField: []") of
|
||||
case decodeEither' @Config $ encodeUtf8 $ defConfigText GitHub <> "strangeField: []" of
|
||||
Left (AesonException str) ->
|
||||
if "unknown fields: [\"strangeField\"]" `isInfixOf` str
|
||||
then pure ()
|
||||
|
Loading…
Reference in New Issue
Block a user