mirror of
https://github.com/serokell/xrefcheck.git
synced 2024-08-17 09:30:35 +03:00
[INT-31] Add config and CLI options
This commit is contained in:
parent
d1ee907cfb
commit
56b4e38308
17
.crossref-verifier.yaml
Normal file
17
.crossref-verifier.yaml
Normal file
@ -0,0 +1,17 @@
|
||||
# Parameters of repository traversal.
|
||||
traversal:
|
||||
# Full paths which should be excluded from consideration.
|
||||
excluded:
|
||||
- .stack-work
|
||||
|
||||
# Parameters of verification.
|
||||
verification:
|
||||
# On 'anchor not found' error, how 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: 1s
|
||||
|
||||
# Verbosity.
|
||||
verbose: false
|
19
exec/Main.hs
19
exec/Main.hs
@ -1,8 +1,10 @@
|
||||
module Main where
|
||||
|
||||
import Data.Default (def)
|
||||
import Data.Yaml (decodeFileEither)
|
||||
import Fmt (blockListF', build, fmt, fmtLn, indentF)
|
||||
|
||||
import Crv.CLI
|
||||
import Crv.Config
|
||||
import Crv.Scan
|
||||
import Crv.Scanners
|
||||
import Crv.Verify
|
||||
@ -14,14 +16,19 @@ formats = specificFormatsSupport
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
let root = "../disciplina"
|
||||
repoInfo <- gatherRepoInfo formats def root
|
||||
fmtLn $ "Repository data:\n\n" <> indentF 2 (build repoInfo)
|
||||
Options{..} <- getOptions
|
||||
let root = oRoot
|
||||
config <- decodeFileEither oConfig
|
||||
>>= either (error . show) pure
|
||||
|
||||
verifyRes <- verifyRepo root repoInfo
|
||||
repoInfo <- gatherRepoInfo formats (cTraversal config) root
|
||||
when (cVerbose config) $
|
||||
fmtLn $ "Repository data:\n\n" <> indentF 2 (build repoInfo)
|
||||
|
||||
verifyRes <- verifyRepo (cVerification config) root repoInfo
|
||||
case verifyErrors verifyRes of
|
||||
Nothing ->
|
||||
fmtLn "All repository links are valid"
|
||||
fmtLn "All repository links are valid."
|
||||
Just (toList -> errs) -> do
|
||||
fmt $ "Invalid references found:\n\n" <>
|
||||
indentF 2 (blockListF' ("➥ ") build errs)
|
||||
|
@ -48,6 +48,8 @@ ghc-options:
|
||||
- -Wall
|
||||
|
||||
dependencies:
|
||||
- aeson
|
||||
- aeson-options
|
||||
- base-noprelude
|
||||
- containers
|
||||
- cmark-gfm
|
||||
@ -64,10 +66,13 @@ dependencies:
|
||||
- pretty-terminal
|
||||
- network-uri
|
||||
- mtl
|
||||
- o-clock
|
||||
- optparse-applicative
|
||||
- req
|
||||
- roman-numerals
|
||||
- text
|
||||
- text-metrics
|
||||
- yaml
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
|
44
src/Crv/CLI.hs
Normal file
44
src/Crv/CLI.hs
Normal file
@ -0,0 +1,44 @@
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
|
||||
module Crv.CLI
|
||||
( Options (..)
|
||||
, getOptions
|
||||
) where
|
||||
|
||||
import Data.Version (showVersion)
|
||||
import Options.Applicative (Parser, execParser, fullDesc, help, helper, info, infoOption, long,
|
||||
metavar, progDesc, short, strOption, value)
|
||||
import Paths_crossref_verifier (version)
|
||||
|
||||
data Options = Options
|
||||
{ oConfig :: FilePath
|
||||
, oRoot :: FilePath
|
||||
}
|
||||
|
||||
optionsParser :: Parser Options
|
||||
optionsParser = do
|
||||
oConfig <- strOption $
|
||||
short 'c' <>
|
||||
long "config" <>
|
||||
metavar "FILEPATH" <>
|
||||
help "Path to configuration file." <>
|
||||
value ".crossref-verifier.yaml"
|
||||
oRoot <- strOption $
|
||||
short 'r' <>
|
||||
long "root" <>
|
||||
metavar "DIRECTORY" <>
|
||||
help "Path to repository root." <>
|
||||
value ""
|
||||
return Options{..}
|
||||
|
||||
versionOption :: Parser (a -> a)
|
||||
versionOption = infoOption ("crossref-verify-" <> (showVersion version)) $
|
||||
long "version" <>
|
||||
help "Show version."
|
||||
|
||||
getOptions :: IO Options
|
||||
getOptions = do
|
||||
execParser $
|
||||
info (helper <*> versionOption <*> optionsParser) $
|
||||
fullDesc <>
|
||||
progDesc "Github repository cross-references verifier."
|
@ -1,17 +1,61 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Crv.Config where
|
||||
|
||||
import Data.Default (Default (..))
|
||||
import Data.Aeson (FromJSON (..), withText)
|
||||
import Data.Aeson.Options (defaultOptions)
|
||||
import Data.Aeson.TH (deriveFromJSON)
|
||||
import Data.Default (Default (..))
|
||||
import Time (KnownRatName, Second, Time, sec, unitsP)
|
||||
|
||||
-- | Overall config.
|
||||
data Config = Config
|
||||
{ cTraversal :: TraversalConfig
|
||||
{ cTraversal :: TraversalConfig
|
||||
, cVerification :: VerifyConfig
|
||||
, cVerbose :: Bool
|
||||
}
|
||||
|
||||
instance Default Config where
|
||||
def = Config def
|
||||
|
||||
-- | Config of repositry traversal.
|
||||
data TraversalConfig = TraversalConfig
|
||||
{ tcExcluded :: [FilePath]
|
||||
}
|
||||
|
||||
-- | Config of verification.
|
||||
data VerifyConfig = VerifyConfig
|
||||
{ vcAnchorSimilarityThreshold :: Double
|
||||
, vcExternalRefCheckTimeout :: Time Second
|
||||
}
|
||||
|
||||
-----------------------------------------------------------
|
||||
-- Default instances
|
||||
-----------------------------------------------------------
|
||||
|
||||
instance Default Config where
|
||||
def =
|
||||
Config
|
||||
{ cTraversal = def
|
||||
, cVerification = def
|
||||
, cVerbose = False
|
||||
}
|
||||
|
||||
instance Default TraversalConfig where
|
||||
def = TraversalConfig [".stack-work"]
|
||||
def = TraversalConfig []
|
||||
|
||||
instance Default VerifyConfig where
|
||||
def =
|
||||
VerifyConfig
|
||||
{ vcAnchorSimilarityThreshold = 0.5
|
||||
, vcExternalRefCheckTimeout = sec 1
|
||||
}
|
||||
|
||||
-----------------------------------------------------------
|
||||
-- Yaml instances
|
||||
-----------------------------------------------------------
|
||||
|
||||
deriveFromJSON defaultOptions ''Config
|
||||
deriveFromJSON defaultOptions ''TraversalConfig
|
||||
deriveFromJSON defaultOptions ''VerifyConfig
|
||||
|
||||
instance KnownRatName unit => FromJSON (Time unit) where
|
||||
parseJSON = withText "time" $
|
||||
maybe (fail "Unknown time") pure . unitsP . toString
|
||||
|
@ -30,8 +30,9 @@ import System.Console.Pretty (Style (..), style)
|
||||
import System.Directory (doesDirectoryExist, doesFileExist)
|
||||
import System.FilePath.Posix (takeDirectory)
|
||||
import System.FilePath.Posix ((</>))
|
||||
import System.Timeout (timeout)
|
||||
import Time (timeout)
|
||||
|
||||
import Crv.Config
|
||||
import Crv.Core
|
||||
|
||||
-----------------------------------------------------------
|
||||
@ -103,10 +104,12 @@ instance Buildable CrvVerifyError where
|
||||
[h] -> ",\n did you mean " +| h |+ "?\n"
|
||||
hs -> ", did you mean:\n" +| blockListF' " -" build hs
|
||||
|
||||
verifyRepo :: FilePath
|
||||
-> RepoInfo
|
||||
-> IO (VerifyResult $ WithReferenceLoc CrvVerifyError)
|
||||
verifyRepo root (RepoInfo repoInfo) =
|
||||
verifyRepo
|
||||
:: VerifyConfig
|
||||
-> FilePath
|
||||
-> RepoInfo
|
||||
-> IO (VerifyResult $ WithReferenceLoc CrvVerifyError)
|
||||
verifyRepo VerifyConfig{..} root (RepoInfo repoInfo) =
|
||||
concatForM (M.toList repoInfo) $ \(file, fileInfo) ->
|
||||
concatForM (_fiReferences fileInfo) $ \ref@Reference{..} ->
|
||||
fmap (fmap $ WithReferenceLoc file ref) $
|
||||
@ -132,14 +135,16 @@ verifyRepo root (RepoInfo repoInfo) =
|
||||
case find ((== anchor) . aName) givenAnchors of
|
||||
Just _ -> pass
|
||||
Nothing ->
|
||||
let similarAnchors =
|
||||
-- TODO: take from config
|
||||
filter ((> 0.5) . damerauLevenshteinNorm anchor . aName)
|
||||
let isSimilar = (>= vcAnchorSimilarityThreshold)
|
||||
similarAnchors =
|
||||
filter (isSimilar . realToFrac . damerauLevenshteinNorm anchor . aName)
|
||||
givenAnchors
|
||||
in throwError $ AnchorDoesNotExist anchor similarAnchors
|
||||
|
||||
checkExternalResource :: Text -> IO (VerifyResult CrvVerifyError)
|
||||
checkExternalResource link = fmap toVerifyRes $ do
|
||||
checkExternalResource :: VerifyConfig
|
||||
-> Text
|
||||
-> IO (VerifyResult CrvVerifyError)
|
||||
checkExternalResource VerifyConfig{..} link = fmap toVerifyRes $ do
|
||||
makeRequest HEAD >>= \case
|
||||
Right () -> return $ Right ()
|
||||
Left (ExternalResourceUnavailable _ status) | statusCode status == 405
|
||||
@ -157,8 +162,8 @@ checkExternalResource link = fmap toVerifyRes $ do
|
||||
Right (url, option) ->
|
||||
runReq def $ req method url NoReqBody ignoreResponse option
|
||||
|
||||
-- TODO: tunable timeout
|
||||
mres <- liftIO (timeout 3000000 $ void reqLink) `catch` (throwError . processErrors)
|
||||
mres <- liftIO (timeout vcExternalRefCheckTimeout $ void reqLink)
|
||||
`catch` (throwError . processErrors)
|
||||
maybe (throwError $ ExternalResourceSomeError "Response timeout") pure mres
|
||||
|
||||
processErrors = \case
|
||||
|
@ -13,6 +13,7 @@ extra-deps:
|
||||
- pretty-terminal-0.1.0.0
|
||||
- roman-numerals-0.5.1.5
|
||||
- req-1.2.1
|
||||
- aeson-options-0.0.0
|
||||
|
||||
- git: https://github.com/serokell/lootbox.git
|
||||
commit: 34e389808e34f1cfa56f456773682325bed56d17
|
||||
|
Loading…
Reference in New Issue
Block a user