[INT-31] Add config and CLI options

.crossref-verifier.yaml

@@ -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

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"
+    Options{..} <- getOptions
-    repoInfo <- gatherRepoInfo formats def root
+    let root = oRoot
-    fmtLn $ "Repository data:\n\n" <> indentF 2 (build repoInfo)
+    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)

package.yaml

@@ -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

src/Crv/CLI.hs

@@ -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."

src/Crv/Config.hs

@@ -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
+-- | Config of repositry traversal.
-    def = Config def
-
 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

src/Crv/Verify.hs

@@ -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
+verifyRepo
-           -> RepoInfo
+    :: VerifyConfig
-           -> IO (VerifyResult $ WithReferenceLoc CrvVerifyError)
+    -> FilePath
-verifyRepo root (RepoInfo repoInfo) =
+    -> 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 =
+                let isSimilar = (>= vcAnchorSimilarityThreshold)
-                        -- TODO: take from config
+                    similarAnchors =
-                        filter ((> 0.5) . damerauLevenshteinNorm anchor . aName)
+                        filter (isSimilar . realToFrac . damerauLevenshteinNorm anchor . aName)
                         givenAnchors
                 in throwError $ AnchorDoesNotExist anchor similarAnchors
 
-checkExternalResource :: Text -> IO (VerifyResult CrvVerifyError)
+checkExternalResource :: VerifyConfig
-checkExternalResource link = fmap toVerifyRes $ do
+                      -> 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 vcExternalRefCheckTimeout $ void reqLink)
-        mres <- liftIO (timeout 3000000 $ void reqLink) `catch` (throwError . processErrors)
+                `catch` (throwError . processErrors)
         maybe (throwError $ ExternalResourceSomeError "Response timeout") pure mres
 
     processErrors = \case

stack.yaml

@@ -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