[#226] Change output formatting

* cli: avoid spaces in metavar * errors: change formatting * tests: accept new output
serokell · Nov 21, 2024 · be889c2 · be889c2
1 parent 671f527
commit be889c2
Show file tree

Hide file tree

Showing 37 changed files with 685 additions and 992 deletions.
diff --git a/package.yaml b/package.yaml
@@ -93,6 +93,7 @@ library:
     - filepath
     - fmt
     - ftp-client
+    - crypton-connection
     - Glob
     - http-client
     - http-types

diff --git a/src/Xrefcheck/CLI.hs b/src/Xrefcheck/CLI.hs
@@ -208,7 +208,7 @@ exclusionOptionsParser :: Parser ExclusionOptions
 exclusionOptionsParser = do
   eoIgnore <- many . globOption $
     long "ignore" <>
-    metavar "GLOB PATTERN" <>
+    metavar "GLOB_PATTERN" <>
     help "Ignore these files. References to them will fail verification,\
          \ and references from them will not be verified.\
          \ Glob patterns that contain wildcards MUST be enclosed\
@@ -237,7 +237,7 @@ dumpConfigOptions = hsubparser $
       option repoTypeReadM $
       short 't' <>
       long "type" <>
-      metavar "REPOSITORY TYPE" <>
+      metavar "REPOSITORY_TYPE" <>
       help [int||
       Git repository type. \
       Can be (#{intercalate " | " $ map show allFlavors}). \

diff --git a/src/Xrefcheck/Command.hs b/src/Xrefcheck/Command.hs
@@ -92,7 +92,8 @@ defaultAction Options{..} = do
       verifyRepo rw fullConfig oMode repoInfo
 
     case verifyErrors verifyRes of
-      Nothing | null scanErrs -> fmtLn "All repository links are valid."
+      Nothing | null scanErrs ->
+        fmtLn $ colorIfNeeded Green "All repository links are valid."
       Nothing -> exitFailure
       Just verifyErrs -> do
         unless (null scanErrs) $ fmt "\n"

diff --git a/src/Xrefcheck/Core.hs b/src/Xrefcheck/Core.hs
@@ -63,10 +63,8 @@ instance FromJSON Flavor where
 newtype Position = Position (Maybe Text)
   deriving stock (Show, Eq, Generic)
 
-instance Given ColorMode => Buildable Position where
-  build (Position pos) = case pos of
-    Nothing -> ""
-    Just p  -> styleIfNeeded Faint $ "at src:" <> build p
+instance Buildable Position where
+  build (Position pos) = maybe "" build pos
 
 -- | Full info about a reference.
 data Reference = Reference
@@ -274,7 +272,7 @@ instance Given ColorMode => Buildable Reference where
 instance Given ColorMode => Buildable AnchorType where
   build = styleIfNeeded Faint . \case
     HeaderAnchor l -> colorIfNeeded Green ("header " <> headerLevelToRoman l)
-    HandAnchor -> colorIfNeeded Yellow "hand made"
+    HandAnchor -> colorIfNeeded Yellow "handmade"
     BiblioAnchor -> colorIfNeeded Cyan "biblio"
     where
       headerLevelToRoman = \case

diff --git a/src/Xrefcheck/Scan.hs b/src/Xrefcheck/Scan.hs
@@ -37,7 +37,7 @@ import Control.Lens (_1, makeLensesWith, (%~))
 import Data.Aeson (FromJSON (..), genericParseJSON, withText)
 import Data.Map qualified as M
 import Data.Reflection (Given)
-import Fmt (Buildable (..), fmt)
+import Fmt (Buildable (..), Builder, fmtLn)
 import System.Directory (doesDirectoryExist, pathIsSymbolicLink)
 import System.Process (cwd, readCreateProcess, shell)
 import Text.Interpolation.Nyan
@@ -120,23 +120,20 @@ mkGatherScanError seFile ScanError{sePosition, seDescription} = ScanError
   , seDescription
   }
 
-instance Given ColorMode => Buildable (ScanError 'Gather) where
-  build ScanError{..} = [int||
-    In file #{styleIfNeeded Faint (styleIfNeeded Bold seFile)}
-    scan error #{sePosition}:
-
-    #{seDescription}
-
-    |]
+pprScanErr :: Given ColorMode => ScanError 'Gather -> Builder
+pprScanErr ScanError{..} = hdr <> "\n" <> interpolateIndentF 2 msg <> "\n"
+  where
+    hdr, msg :: Builder
+    hdr =
+      styleIfNeeded Bold (build seFile <> ":" <> build sePosition <> ": ") <>
+      colorIfNeeded Red "scan error:"
+    msg = build seDescription
 
 reportScanErrs :: Given ColorMode => NonEmpty (ScanError 'Gather) -> IO ()
-reportScanErrs errs = fmt
-  [int||
-  === Scan errors found ===
-
-  #{interpolateIndentF 2 (interpolateBlockListF' "➥ " build errs)}
-  Scan errors dumped, #{length errs} in total.
-  |]
+reportScanErrs errs = do
+  traverse_ (fmtLn . pprScanErr) errs
+  fmtLn $ colorIfNeeded Red $
+    "Scan errors dumped, " <> build (length errs) <> " in total."
 
 data ScanErrorDescription
   = LinkErr
@@ -152,8 +149,8 @@ instance Buildable ScanErrorDescription where
                      markdown or right after comments at the top|]
     ParagraphErr txt -> [int||Expected a PARAGRAPH after \
                               "ignore paragraph" annotation, but found #{txt}|]
-    UnrecognisedErr txt -> [int||Unrecognised option "#{txt}" perhaps you meant \
-                                 <"ignore link"|"ignore paragraph"|"ignore all">|]
+    UnrecognisedErr txt -> [int||Unrecognised option "#{txt}"
+                                 Perhaps you meant <"ignore link"|"ignore paragraph"|"ignore all">|]
 
 firstFileSupport :: [FileSupport] -> FileSupport
 firstFileSupport fs isSymlink =

diff --git a/src/Xrefcheck/Verify.hs b/src/Xrefcheck/Verify.hs
@@ -46,9 +46,10 @@ import Data.Text.Metrics (damerauLevenshteinNorm)
 import Data.Time (UTCTime, defaultTimeLocale, formatTime, readPTime, rfc822DateFormat)
 import Data.Time.Clock.POSIX (getPOSIXTime)
 import Data.Traversable (for)
-import Fmt (Buildable (..), Builder, fmt, maybeF, nameF)
+import Fmt (Buildable (..), Builder, fmt, fmtLn, maybeF, nameF)
 import GHC.Exts qualified as Exts
 import GHC.Read (Read (readPrec))
+import Network.Connection qualified as N.C
 import Network.FTP.Client
   (FTPException (..), FTPResponse (..), ResponseStatus (..), login, nlst, size, withFTP, withFTPS)
 import Network.HTTP.Client
@@ -107,13 +108,6 @@ data WithReferenceLoc a = WithReferenceLoc
   , wrlItem      :: a
   }
 
-instance (Given ColorMode, Buildable a) => Buildable (WithReferenceLoc a) where
-  build WithReferenceLoc{..} = [int||
-    In file #{styleIfNeeded Faint (styleIfNeeded Bold wrlFile)}
-    bad #{wrlReference}
-    #{wrlItem}
-    |]
-
 -- | Contains a name of a domain, examples:
 -- @DomainName "github.com"@,
 -- @DomainName "localhost"@,
@@ -137,6 +131,7 @@ data VerifyError
   | ExternalFtpException FTPException
   | FtpEntryDoesNotExist FilePath
   | ExternalResourceSomeError Text
+  | ExternalResourceConnectionFailure
   | RedirectChainCycle RedirectChain
   | RedirectMissingLocation RedirectChain
   | RedirectChainLimit RedirectChain
@@ -147,8 +142,8 @@ data ResponseResult
   = RRDone
   | RRFollow Text
 
-instance Given ColorMode => Buildable VerifyError where
-  build = \case
+pprVerifyErr' :: Given ColorMode => VerifyError -> Builder
+pprVerifyErr' = \case
     LocalFileDoesNotExist file ->
       [int||
       File does not exist:
@@ -256,6 +251,11 @@ instance Given ColorMode => Buildable VerifyError where
       #{err}
       |]
 
+    ExternalResourceConnectionFailure ->
+      [int||
+      Connection failure
+      |]
+
     RedirectChainCycle chain ->
       [int||
       Cycle found in the following redirect chain:
@@ -304,15 +304,48 @@ incTotalCounter rc = rc {rcTotalRetries = rcTotalRetries rc + 1}
 incTimeoutCounter :: RetryCounter -> RetryCounter
 incTimeoutCounter rc = rc {rcTimeoutRetries = rcTimeoutRetries rc + 1}
 
+pprVerifyErr :: Given ColorMode => WithReferenceLoc VerifyError -> Builder
+pprVerifyErr wrl = hdr <> "\n" <> interpolateIndentF 2 msg
+  where
+    WithReferenceLoc{wrlFile, wrlReference, wrlItem} = wrl
+    Reference{rName, rInfo} = wrlReference
+
+    hdr, msg :: Builder
+    hdr =
+      styleIfNeeded Bold (build wrlFile <> ":" <> build (rPos wrlReference) <> ": ") <>
+      colorIfNeeded Red "bad reference:"
+    msg =
+      "The reference to " <> show rName <> " failed verification.\n" <>
+      mconcat (map (\info -> "- " <> info <> "\n") ref_infos)  <>
+      pprVerifyErr' wrlItem
+
+    ref_infos :: [Builder]
+    ref_infos = case rInfo of
+      RIFile ReferenceInfoFile{..} ->
+        case rifLink of
+          FLLocal ->
+            case rifAnchor of
+              Nothing  -> []
+              Just anc -> ["anchor " <> paren (styleIfNeeded Faint "file-local") <> ": " <> build anc]
+          FLRelative link ->
+            ["link " <> paren (styleIfNeeded Faint "relative") <> ": " <> build link] ++
+            (case rifAnchor of
+              Nothing  -> []
+              Just anc -> ["anchor: " <> build anc])
+          FLAbsolute link ->
+            ["link " <> paren (styleIfNeeded Faint "absolute") <> ": " <> build link] ++
+            (case rifAnchor of
+              Nothing  -> []
+              Just anc -> ["anchor: " <> build anc])
+      RIExternal (ELUrl url) -> ["link " <> paren (styleIfNeeded Faint "external") <> ": " <> build url]
+      RIExternal (ELOther url) -> ["link: " <> build url]
+
 reportVerifyErrs
   :: Given ColorMode => NonEmpty (WithReferenceLoc VerifyError) -> IO ()
-reportVerifyErrs errs = fmt
-  [int||
-  === Invalid references found ===
-
-  #{interpolateIndentF 2 (interpolateBlockListF' "➥ " build errs)}
-  Invalid references dumped, #{length errs} in total.
-  |]
+reportVerifyErrs errs = do
+  traverse_ (fmtLn . pprVerifyErr) errs
+  fmtLn $ colorIfNeeded Red $
+    "Invalid references dumped, " <> build (length errs) <> " in total."
 
 data RetryAfter = Date UTCTime | Seconds (Time Second)
   deriving stock (Show, Eq)
@@ -708,7 +741,7 @@ checkExternalResource followed config@Config{..} link
       let maxTime = Time @Second $ unTime ncExternalRefCheckTimeout * timeoutFrac
 
       reqRes <- catch (liftIO (timeout maxTime $ reqLink $> RRDone)) $
-         (Just <$>) <$> interpretErrors uri
+         (Just <$>) <$> interpretHttpErrors uri
 
       case reqRes of
         Nothing -> throwError $ ExternalHttpTimeout $ extractHost uri
@@ -730,9 +763,13 @@ checkExternalResource followed config@Config{..} link
       , (405 ==) -- method mismatch
       ]
 
-    interpretErrors uri = \case
+    interpretHttpErrors :: URI -> Network.HTTP.Req.HttpException -> ExceptT VerifyError IO ResponseResult
+    interpretHttpErrors uri = \case
       JsonHttpException _ -> error "External link JSON parse exception"
-      VanillaHttpException err -> case err of
+      VanillaHttpException err -> interpretHttpErrors' uri err
+
+    interpretHttpErrors' :: URI -> Network.HTTP.Client.HttpException -> ExceptT VerifyError IO ResponseResult
+    interpretHttpErrors' uri = \case
         InvalidUrlException{} -> error "External link URL invalid exception"
         HttpExceptionRequest _ exc -> case exc of
           StatusCodeException resp _
@@ -765,6 +802,12 @@ checkExternalResource followed config@Config{..} link
               redirectLocation = fmap decodeUtf8
                 . lookup "Location"
                 $ responseHeaders resp
+
+          ConnectionFailure _ -> throwError ExternalResourceConnectionFailure
+          InternalException e
+            | Just (N.C.HostCannotConnect _ _) <- fromException e
+            -> throwError ExternalResourceConnectionFailure
+
           other -> throwError $ ExternalResourceSomeError $ show other
       where
         retryAfterInfo :: Response a -> Maybe RetryAfter

diff --git a/tests/golden/check-anchors/expected1.gold b/tests/golden/check-anchors/expected1.gold
@@ -1,32 +1,26 @@
-=== Invalid references found ===
+a.md:16:1-43: bad reference:
+  The reference to "ambiguous anchor in this file" failed verification.
+  - anchor (file-local): some-text
+  Ambiguous reference to anchor 'some-text'
+    In file a.md
+    It could refer to either:
+      - some-text (header I) 6:1-11
+      - some-text (header I) 8:1-15
+      - some-text (header II) 12:1-12
+    Use of ambiguous anchors is discouraged because the target
+    can change silently while the document containing it evolves.
 
-  ➥  In file a.md
-     bad reference (file-local) at src:16:1-43:
-       - text: "ambiguous anchor in this file"
-       - anchor: some-text
-
-     Ambiguous reference to anchor 'some-text'
-       In file a.md
-       It could refer to either:
-         - some-text (header I) at src:6:1-11
-         - some-text (header I) at src:8:1-15
-         - some-text (header II) at src:12:1-12
-       Use of ambiguous anchors is discouraged because the target
-       can change silently while the document containing it evolves.
-
-  ➥  In file b.md
-     bad reference (relative) at src:7:1-48:
-       - text: "ambiguous anchor in other file"
-       - link: a.md
-       - anchor: some-text
-
-     Ambiguous reference to anchor 'some-text'
-       In file a.md
-       It could refer to either:
-         - some-text (header I) at src:6:1-11
-         - some-text (header I) at src:8:1-15
-         - some-text (header II) at src:12:1-12
-       Use of ambiguous anchors is discouraged because the target
-       can change silently while the document containing it evolves.
+b.md:7:1-48: bad reference:
+  The reference to "ambiguous anchor in other file" failed verification.
+  - link (relative): a.md
+  - anchor: some-text
+  Ambiguous reference to anchor 'some-text'
+    In file a.md
+    It could refer to either:
+      - some-text (header I) 6:1-11
+      - some-text (header I) 8:1-15
+      - some-text (header II) 12:1-12
+    Use of ambiguous anchors is discouraged because the target
+    can change silently while the document containing it evolves.
 
 Invalid references dumped, 2 in total.
diff --git a/tests/golden/check-anchors/expected2.gold b/tests/golden/check-anchors/expected2.gold
@@ -1,27 +1,19 @@
-=== Invalid references found ===
+a.md:12:1-13: bad reference:
+  The reference to "broken" failed verification.
+  - anchor (file-local): h3
+  Anchor 'h3' is not present, did you mean:
+      - h1 (header I) 6:1-4
+      - h2 (header II) 8:1-5
 
-  ➥  In file a.md
-     bad reference (file-local) at src:12:1-13:
-       - text: "broken"
-       - anchor: h3
+a.md:14:1-18: bad reference:
+  The reference to "broken" failed verification.
+  - anchor (file-local): heading
+  Anchor 'heading' is not present, did you mean:
+      - the-heading (header I) 10:1-13
 
-     Anchor 'h3' is not present, did you mean:
-         - h1 (header I) at src:6:1-4
-         - h2 (header II) at src:8:1-5
-
-  ➥  In file a.md
-     bad reference (file-local) at src:14:1-18:
-       - text: "broken"
-       - anchor: heading
-
-     Anchor 'heading' is not present, did you mean:
-         - the-heading (header I) at src:10:1-13
-
-  ➥  In file a.md
-     bad reference (file-local) at src:16:1-31:
-       - text: "broken"
-       - anchor: really-unique-anchor
-
-     Anchor 'really-unique-anchor' is not present
+a.md:16:1-31: bad reference:
+  The reference to "broken" failed verification.
+  - anchor (file-local): really-unique-anchor
+  Anchor 'really-unique-anchor' is not present
 
 Invalid references dumped, 3 in total.
diff --git a/tests/golden/check-autolinks/expected.gold b/tests/golden/check-autolinks/expected.gold
@@ -5,22 +5,18 @@
         - reference (external):
             - text: "https://www.google.com/doodles"
             - link: https://www.google.com/doodles
-        - reference (external) at src:8:0-18:
+        - reference (external) 8:0-18:
             - text: "www.commonmark.org"
             - link: http://www.commonmark.org
     - anchors:
         none
 
-=== Invalid references found ===
-
-  ➥  In file file-with-autolinks.md
-     bad reference (external) at src:8:0-18:
-       - text: "www.commonmark.org"
-       - link: http://www.commonmark.org
-
-     Permanent redirect found:
-       -| http://www.commonmark.org
-       -> https://commonmark.org
-          ^-- stopped before this one
+file-with-autolinks.md:8:0-18: bad reference:
+  The reference to "www.commonmark.org" failed verification.
+  - link (external): http://www.commonmark.org
+  Permanent redirect found:
+    -| http://www.commonmark.org
+    -> https://commonmark.org
+       ^-- stopped before this one
 
 Invalid references dumped, 1 in total.