serokell/xrefcheck
1
1
Fork 0
mirror of https://github.com/serokell/xrefcheck.git synced 2024-08-16 17:10:26 +03:00
Code Issues Projects Releases Wiki Activity

[#149] Replace hspec with tasty

Browse Source 
Problem: `hspec` and `tasty` are testing frameworks with
almost same functionality,
for historical reasons in xrefcheck we  used different frameworks
for tests and links-tests, and in Serokell we prefer `tasty` now.

Solution: use only `tasty`,
 rewrite code that use `hspec` using correspondance between
 - `testGroup` and `describe`
 -  `testCase` and `it`
 - `shouldBe` and `@?=`
This commit is contained in:
Anton Sorokin 2022-09-20 11:54:20 +03:00
parent 955e0ea9cf
commit b412781020
No known key found for this signature in database
GPG Key ID: 4B53B91ADFBFB649
20 changed files with 237 additions and 225 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.reuse/dep5
View File

@ -4,7 +4,7 @@ Files: .github/pull_request_template.md .github/ISSUE_TEMPLATE/*.md
Copyright: 2018-2019 Serokell <https://serokell.io>
License: Unlicense
Files: links-tests/ftp_root/**/*
Files: ftp-tests/ftp_root/**/*
Copyright: 2021 Serokell <https://serokell.io>
License: Unlicense

0
links-tests/Main.hs → ftp-tests/Main.hs
View File

0
links-tests/Test/Xrefcheck/FtpLinks.hs → ftp-tests/Test/Xrefcheck/FtpLinks.hs
View File

0
links-tests/Tree.hs → ftp-tests/Tree.hs
View File

0
links-tests/ftp_root/empty/.gitkeep → ftp-tests/ftp_root/empty/.gitkeep
View File

0
links-tests/ftp_root/pub/file_exists.txt → ftp-tests/ftp_root/pub/file_exists.txt
View File

14
package.yaml
View File

@ -133,6 +133,7 @@ tests:
xrefcheck-tests:
main: Main.hs
source-dirs: tests
build-tools: tasty-discover:tasty-discover
generated-other-modules:
- Paths_xrefcheck
dependencies:
@ -140,28 +141,25 @@ tests:
- containers
- cmark-gfm
- firefly
- hspec
- hspec-expectations
- QuickCheck
- xrefcheck
- bytestring
- directory
- fmt
- http-types
- HUnit
- o-clock
- regex-tdfa
- tasty
- tasty-hunit
- tasty-quickcheck
- time
- universum
- modern-uri
- uri-bytestring
- yaml
build-tools:
- hspec-discover
links-tests:
ftp-tests:
main: Main.hs
source-dirs: links-tests
source-dirs: ftp-tests
build-tools: tasty-discover:tasty-discover
generated-other-modules:
- Paths_xrefcheck

17
tests/Main.hs
View File

@ -1,12 +1,15 @@
{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>
-
- SPDX-License-Identifier: MPL-2.0
-}
-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>
--
-- SPDX-License-Identifier: MPL-2.0
module Main
( main
) where
import Universum
import Spec (spec)
import Test.Hspec (hspec)
import Test.Tasty
import Tree (tests)
main :: IO ()
main = hspec spec
main = tests >>= defaultMain

6
tests/Spec.hs
View File

@ -1,6 +0,0 @@
{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>
-
- SPDX-License-Identifier: MPL-2.0
-}
{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}

28
tests/Test/Xrefcheck/AnchorsInHeadersSpec.hs
View File

@ -7,21 +7,21 @@ module Test.Xrefcheck.AnchorsInHeadersSpec where
import Universum
import Test.Hspec (Spec, describe, it, shouldBe)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase, (@?=))
import Xrefcheck.Core
import Test.Xrefcheck.Util
spec :: Spec
spec = do
describe "Anchors in headers" $ do
it "Check if anchors in headers are recognized" $ do
fi <- getFI GitHub "tests/markdowns/without-annotations/anchors_in_headers.md"
getAnchors fi `shouldBe` ["some-stuff", "stuff-section"]
it "Check if anchors with id attributes are recognized" $ do
fi <- getFI GitHub "tests/markdowns/without-annotations/anchors_in_headers_with_id_attribute.md"
getAnchors fi `shouldBe` ["some-stuff-with-id-attribute", "stuff-section-with-id-attribute"]
where
getAnchors :: FileInfo -> [Text]
getAnchors fi = map aName $ fi ^. fiAnchors
test_anchorsInHeaders :: TestTree
test_anchorsInHeaders = testGroup "Anchors in headers"
[ testCase "Check if anchors in headers are recognized" $ do
fi <- getFI GitHub "tests/markdowns/without-annotations/anchors_in_headers.md"
getAnchors fi @?= ["some-stuff", "stuff-section"]
, testCase "Check if anchors with id attributes are recognized" $ do
fi <- getFI GitHub "tests/markdowns/without-annotations/anchors_in_headers_with_id_attribute.md"
getAnchors fi @?= ["some-stuff-with-id-attribute", "stuff-section-with-id-attribute"]
]
where
getAnchors :: FileInfo -> [Text]
getAnchors fi = map aName $ fi ^. fiAnchors

41
tests/Test/Xrefcheck/AnchorsSpec.hs
View File

@ -3,37 +3,36 @@
- SPDX-License-Identifier: MPL-2.0
-}
module Test.Xrefcheck.AnchorsSpec (spec) where
module Test.Xrefcheck.AnchorsSpec (test_anchors) where
import Universum
import Test.Hspec (Spec, describe, it, shouldBe)
import Test.QuickCheck ((===))
import Test.Tasty (testGroup, TestTree)
import Test.Tasty.HUnit ((@?=), testCase)
import Test.Xrefcheck.Util
import Xrefcheck.Core
checkHeaderConversions
:: HasCallStack
=> Flavor -> [(Text, Text)] -> Spec
checkHeaderConversions :: Flavor -> [(Text, Text)] -> TestTree
checkHeaderConversions fl suites =
describe (show fl) $ do
forM_ suites $ \(a, b) ->
it (show a <> " == " <> show b) $ headerToAnchor fl a === b
it "Non-stripped header name should be stripped" $ do
fi <- getFI fl "tests/markdowns/without-annotations/non_stripped_spaces.md"
getAnchors fi `shouldBe` [ case fl of GitHub -> "header--with-leading-spaces"
GitLab -> "header-with-leading-spaces"
, "edge-case"
]
testGroup (show fl) $
[testCase (show a <> " == " <> show b) $ headerToAnchor fl a @?= b | (a,b) <- suites]
++
[ testCase "Non-stripped header name should be stripped" $ do
fi <- getFI fl "tests/markdowns/without-annotations/non_stripped_spaces.md"
getAnchors fi @?= [ case fl of GitHub -> "header--with-leading-spaces"
GitLab -> "header-with-leading-spaces"
, "edge-case"
]
]
where
getAnchors :: FileInfo -> [Text]
getAnchors fi = map aName $ fi ^. fiAnchors
spec :: Spec
spec = do
describe "Header-to-anchor conversion" $ do
checkHeaderConversions GitHub
test_anchors :: TestTree
test_anchors = do
testGroup "Header-to-anchor conversion"
[ checkHeaderConversions GitHub
[ ( "Some header"
, "some-header"
)
@ -92,8 +91,7 @@ spec = do
, "white_check_mark-checklist-for-your-pull-request"
)
]
checkHeaderConversions GitLab
, checkHeaderConversions GitLab
[ ( "a # b"
, "a-b"
)
@ -134,3 +132,4 @@ spec = do
, "white_check_mark-checklist-for-your-pull-request"
)
]
]

90
tests/Test/Xrefcheck/ConfigSpec.hs
View File

@ -12,63 +12,63 @@ import Control.Exception qualified as E
import Data.ByteString qualified as BS
import Network.HTTP.Types (Status (..))
import Test.Hspec (Spec, before, describe, it, shouldBe)
import Test.Hspec.Expectations (expectationFailure)
import Test.QuickCheck (ioProperty, once)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (ioProperty, testProperty)
import Xrefcheck.Config (Config, Config' (..), VerifyConfig' (..), defConfig, defConfigText)
import Xrefcheck.Core (Flavor (GitHub), allFlavors)
import Xrefcheck.Verify (VerifyError (..), VerifyResult (..), checkExternalResource)
import Test.Xrefcheck.Util (mockServer)
import Test.Tasty.HUnit (testCase, assertFailure, (@?=))
spec :: Spec
spec = do
describe "Default config is valid" $
forM_ allFlavors $ \flavor ->
it (show flavor) $
once . ioProperty $ evaluateWHNF_ @_ @Config (defConfig flavor)
test_config :: [TestTree]
test_config =
[ testGroup "Default config is valid" [
testProperty (show flavor) $
ioProperty $ evaluateWHNF_ @_ @Config (defConfig flavor)
| flavor <- allFlavors]
describe "Filled default config matches the expected format" $
before (BS.readFile "tests/configs/github-config.yaml") $
-- The config we match against can be regenerated with
-- stack exec xrefcheck -- dump-config -t GitHub -o tests/configs/github-config.yaml
it "Config matches" $
\config ->
when (config /= defConfigText GitHub) $
expectationFailure $ toString $ unwords
[ "Config does not match the expected format."
, "Run"
, "`stack exec xrefcheck -- dump-config -t GitHub -o tests/configs/github-config.yaml`"
, "and verify changes"
, testGroup "Filled default config matches the expected format" [
-- 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"
when (config /= defConfigText GitHub) $
assertFailure $ toString $ unwords
[ "Config does not match the expected format."
, "Run"
, "`stack exec xrefcheck -- dump-config -t GitHub -o tests/configs/github-config.yaml`"
, "and verify changes"
]
]
, testGroup "`ignoreAuthFailures` working as expected" $
let config = (cVerification $ defConfig GitHub) { vcIgnoreRefs = [] }
in [ testCase "when True - assume 401 status is valid" $
checkLinkWithServer (config { vcIgnoreAuthFailures = True })
"http://127.0.0.1:3000/401" $ VerifyResult []
, testCase "when False - assume 401 status is invalid" $
checkLinkWithServer (config { vcIgnoreAuthFailures = False })
"http://127.0.0.1:3000/401" $ VerifyResult
[ ExternalHttpResourceUnavailable $
Status { statusCode = 401, statusMessage = "Unauthorized" }
]
describe "`ignoreAuthFailures` working as expected" $ do
let config = (cVerification $ defConfig GitHub) { vcIgnoreRefs = [] }
, testCase "when True - assume 403 status is valid" $
checkLinkWithServer (config { vcIgnoreAuthFailures = True })
"http://127.0.0.1:3000/403" $ VerifyResult []
it "when True - assume 401 status is valid" $
checkLinkWithServer (config { vcIgnoreAuthFailures = True })
"http://127.0.0.1:3000/401" $ VerifyResult []
it "when False - assume 401 status is invalid" $
checkLinkWithServer (config { vcIgnoreAuthFailures = False })
"http://127.0.0.1:3000/401" $ VerifyResult
[ ExternalHttpResourceUnavailable $
Status { statusCode = 401, statusMessage = "Unauthorized" }
]
it "when True - assume 403 status is valid" $
checkLinkWithServer (config { vcIgnoreAuthFailures = True })
"http://127.0.0.1:3000/403" $ VerifyResult []
it "when False - assume 403 status is invalid" $
checkLinkWithServer (config { vcIgnoreAuthFailures = False })
"http://127.0.0.1:3000/403" $ VerifyResult
[ ExternalHttpResourceUnavailable $
Status { statusCode = 403, statusMessage = "Forbidden" }
]
, testCase "when False - assume 403 status is invalid" $
checkLinkWithServer (config { vcIgnoreAuthFailures = False })
"http://127.0.0.1:3000/403" $ VerifyResult
[ ExternalHttpResourceUnavailable $
Status { statusCode = 403, statusMessage = "Forbidden" }
]
]
]
where
checkLinkWithServer config link expectation =
E.bracket (forkIO mockServer) killThread $ \_ -> do
result <- checkExternalResource config link
result `shouldBe` expectation
result @?= expectation

74
tests/Test/Xrefcheck/IgnoreAnnotationsSpec.hs
View File

@ -7,46 +7,52 @@ module Test.Xrefcheck.IgnoreAnnotationsSpec where
import Universum
import CMarkGFM (PosInfo (..))
import Test.Hspec (Spec, describe, it, shouldBe, shouldReturn)
import CMarkGFM (PosInfo(..))
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase, (@?=))
import Test.Xrefcheck.Util
import Xrefcheck.Core
import Xrefcheck.Scan
import Xrefcheck.Scanners.Markdown
spec :: Spec
spec = do
describe "Parsing failures" $ do
it "Check if broken link annotation produce error" do
let file = "tests/markdowns/with-annotations/no_link.md"
getErrs file `shouldReturn`
makeError (Just $ PosInfo 7 1 7 31) file Link ""
it "Check if broken paragraph annotation produce error" do
let file = "tests/markdowns/with-annotations/no_paragraph.md"
getErrs file `shouldReturn`
makeError (Just $ PosInfo 7 1 7 35) file Paragraph "HEADING"
it "Check if broken ignore file annotation produce error" do
let file = "tests/markdowns/with-annotations/unexpected_ignore_file.md"
getErrs file `shouldReturn`
makeError (Just $ PosInfo 9 1 9 30) file File ""
it "Check if broken unrecognised annotation produce error" do
let file = "tests/markdowns/with-annotations/unrecognised_option.md"
getErrs file `shouldReturn`
makeError (Just $ PosInfo 7 1 7 46) file None "unrecognised-option"
describe "\"ignore link\" mode" $ do
it "Check \"ignore link\" performance" $ do
fi <- getFI GitHub "tests/markdowns/with-annotations/ignore_link.md"
getRefs fi `shouldBe`
["team", "team", "team", "hire-us", "how-we-work", "privacy", "link2", "link2"]
describe "\"ignore paragraph\" mode" $ do
it "Check \"ignore paragraph\" performance" $ do
fi <- getFI GitHub "tests/markdowns/with-annotations/ignore_paragraph.md"
getRefs fi `shouldBe` ["blog", "contacts"]
describe "\"ignore file\" mode" $ do
it "Check \"ignore file\" performance" $ do
fi <- getFI GitHub "tests/markdowns/with-annotations/ignore_file.md"
getRefs fi `shouldBe` []
test_ignoreAnnotations :: [TestTree]
test_ignoreAnnotations =
[ testGroup "Parsing failures"
[ testCase "Check if broken link annotation produce error" do
let file = "tests/markdowns/with-annotations/no_link.md"
errs <- getErrs file
errs @?= makeError (Just $ PosInfo 7 1 7 31) file Link ""
, testCase "Check if broken paragraph annotation produce error" do
let file = "tests/markdowns/with-annotations/no_paragraph.md"
errs <- getErrs file
errs @?= makeError (Just $ PosInfo 7 1 7 35) file Paragraph "HEADING"
, testCase "Check if broken ignore file annotation produce error" do
let file = "tests/markdowns/with-annotations/unexpected_ignore_file.md"
errs <- getErrs file
errs @?= makeError (Just $ PosInfo 9 1 9 30) file File ""
, testCase "Check if broken unrecognised annotation produce error" do
let file = "tests/markdowns/with-annotations/unrecognised_option.md"
errs <- getErrs file
errs @?= makeError (Just $ PosInfo 7 1 7 46) file None "unrecognised-option"
]
, testGroup "\"ignore link\" mode"
[ testCase "Check \"ignore link\" performance" $ do
fi <- getFI GitHub "tests/markdowns/with-annotations/ignore_link.md"
getRefs fi @?=
["team", "team", "team", "hire-us", "how-we-work", "privacy", "link2", "link2"]
]
, testGroup "\"ignore paragraph\" mode"
[ testCase "Check \"ignore paragraph\" performance" $ do
fi <- getFI GitHub "tests/markdowns/with-annotations/ignore_paragraph.md"
getRefs fi @?= ["blog", "contacts"]
]
, testGroup "\"ignore file\" mode"
[ testCase "Check \"ignore file\" performance" $ do
fi <- getFI GitHub "tests/markdowns/with-annotations/ignore_file.md"
getRefs fi @?= []
]
]
where
getRefs :: FileInfo -> [Text]
getRefs fi = map rName $ fi ^. fiReferences

34
tests/Test/Xrefcheck/IgnoreRegexSpec.hs
View File

@ -8,8 +8,8 @@ module Test.Xrefcheck.IgnoreRegexSpec where
import Universum
import Data.Yaml (decodeEither')
import Test.HUnit (assertFailure)
import Test.Hspec (Spec, describe, it)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase, assertFailure)
import Text.Regex.TDFA (Regex)
import Xrefcheck.Config
@ -19,22 +19,23 @@ import Xrefcheck.Scan (scanRepo, specificFormatsSupport, ScanResult (..))
import Xrefcheck.Scanners.Markdown
import Xrefcheck.Verify (VerifyError, VerifyResult, WithReferenceLoc (..), verifyErrors, verifyRepo)
spec :: Spec
spec = do
describe "Regular expressions performance" $ do
let root = "tests/markdowns/without-annotations"
let showProgressBar = False
let formats = specificFormatsSupport [markdownSupport defGithubMdConfig]
let verifyMode = ExternalOnlyMode
test_ignoreRegex :: TestTree
test_ignoreRegex =
let root = "tests/markdowns/without-annotations"
showProgressBar = False
formats = specificFormatsSupport [markdownSupport defGithubMdConfig]
verifyMode = ExternalOnlyMode
let linksTxt =
[ "https://bad.((external.)?)reference(/?)"
, "https://bad.reference.(org|com)"
]
let regexs = linksToRegexs linksTxt
let config = setIgnoreRefs regexs (defConfig GitHub)
linksTxt =
[ "https://bad.((external.)?)reference(/?)"
, "https://bad.reference.(org|com)"
]
regexs = linksToRegexs linksTxt
config = setIgnoreRefs regexs (defConfig GitHub)
it "Check that only not matched links are verified" $ do
in testGroup "Regular expressions performance"
[ testCase "Check that only not matched links are verified" $ do
scanResult <- allowRewrite showProgressBar $ \rw ->
scanRepo rw formats (config ^. cTraversalL) root
@ -69,6 +70,7 @@ spec = do
assertFailure $
"Link \"" <> show link <>
"\" is not considered as broken but it is (and shouldn't be ignored)"
]
where
pickBrokenLinks :: VerifyResult (WithReferenceLoc VerifyError) -> [Text]

22
tests/Test/Xrefcheck/LocalSpec.hs
View File

@ -7,19 +7,19 @@ module Test.Xrefcheck.LocalSpec where
import Universum
import Test.Hspec (Spec, describe, it)
import Test.QuickCheck ((===))
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase, (@?=))
import Xrefcheck.Core (canonizeLocalRef)
spec :: Spec
spec = do
describe "Local refs canonizing" $ do
it "Strips ./" $
canonizeLocalRef "./AnchorsSpec.hs" === "AnchorsSpec.hs"
test_local_refs_canonizing :: TestTree
test_local_refs_canonizing = testGroup "Local refs canonizing" $
[ testCase "Strips ./" $
canonizeLocalRef "./AnchorsSpec.hs" @?= "AnchorsSpec.hs"
it "Strips ././" $
canonizeLocalRef "././AnchorsSpec.hs" === "AnchorsSpec.hs"
, testCase "Strips ././" $
canonizeLocalRef "././AnchorsSpec.hs" @?= "AnchorsSpec.hs"
it "Leaves plain other intact" $
canonizeLocalRef "../AnchorsSpec.hs" === "../AnchorsSpec.hs"
, testCase "Leaves plain other intact" $
canonizeLocalRef "../AnchorsSpec.hs" @?= "../AnchorsSpec.hs"
]

35
tests/Test/Xrefcheck/TooManyRequestsSpec.hs
View File

@ -16,8 +16,8 @@ import Data.Time.Clock.POSIX (getPOSIXTime)
import Fmt (indentF, pretty, unlinesF)
import Network.HTTP.Types (Status (..), ok200, serviceUnavailable503, tooManyRequests429)
import Network.HTTP.Types.Header (hRetryAfter)
import Test.Hspec (Spec, describe, it, shouldBe)
import Test.HUnit (assertBool)
import Test.Tasty (testGroup, TestTree)
import Test.Tasty.HUnit (testCase, (@?=), assertBool)
import Time (sec, (-:-))
import Web.Firefly (ToResponse (toResponse), route, run, getMethod)
@ -27,19 +27,18 @@ import Xrefcheck.Progress
import Xrefcheck.Util
import Xrefcheck.Verify
spec :: Spec
spec = do
describe "429 response tests" $ do
it "Returns 200 eventually" $ do
test_tooManyRequests :: TestTree
test_tooManyRequests = testGroup "429 response tests"
[ testCase "Returns 200 eventually" $ do
let prog = Progress{ pTotal = 1
, pCurrent = 1
, pErrorsUnfixable = 0
, pErrorsFixable = 0
, pTaskTimestamp = Nothing
}
, pCurrent = 1
, pErrorsUnfixable = 0
, pErrorsFixable = 0
, pTaskTimestamp = Nothing
}
checkLinkAndProgressWithServer (mock429 "1" ok200)
"http://127.0.0.1:5000/429" prog $ VerifyResult []
it "Returns 503 eventually" $ do
, testCase "Returns 503 eventually" $ do
let prog = Progress{ pTotal = 1
, pCurrent = 1
, pErrorsUnfixable = 1
@ -51,7 +50,7 @@ spec = do
[ ExternalHttpResourceUnavailable $
Status { statusCode = 503, statusMessage = "Service Unavailable"}
]
it "Successfully updates the new retry-after value (as seconds)" $ do
, testCase "Successfully updates the new retry-after value (as seconds)" $ do
E.bracket (forkIO $ mock429 "2" ok200) killThread $ \_ -> do
now <- getPOSIXTime <&> posixTimeToTimeSecond
progressRef <- newIORef VerifyProgress
@ -72,7 +71,7 @@ spec = do
flip assertBool (ttc == Just (sec 2)) $
"Expected time to completion be equal to " ++ show (Just $ sec 2) ++
", but instead it's " ++ show ttc
it "Successfully updates the new retry-after value (as date)" $ do
, testCase "Successfully updates the new retry-after value (as date)" $ do
utctime <- getCurrentTime
let
-- Set the @Retry-After@ response header value as (current datetime + 4 seconds)
@ -97,7 +96,8 @@ spec = do
flip assertBool (sec 3 <= ttc && ttc <= sec 4) $
"Expected time to completion be within range (seconds): 3 <= x <= 4" ++
", but instead it's " ++ show ttc
it "Sets the new retry-after to 0 seconds if its value is a date && has already passed" $ do
, testCase "Sets the new retry-after to 0 seconds if\
\ its value is a date && has already passed" $ do
utctime <- getCurrentTime
let
-- Set the @Retry-After@ response header value as (current datetime - 4 seconds)
@ -122,7 +122,7 @@ spec = do
flip assertBool (ttc == Just (sec 0)) $
"Expected time to completion be 0 seconds" ++
", but instead it's " ++ show ttc
it "The GET request should not be attempted after catching a 429" $ do
, testCase "The GET request should not be attempted after catching a 429" $ do
let
mock429WithGlobalIORef :: IORef [(Text, Status)] -> IO ()
mock429WithGlobalIORef infoReverseAccumulatorRef = do
@ -151,11 +151,12 @@ spec = do
E.bracket (forkIO $ mock429WithGlobalIORef infoReverseAccumulatorRef) killThread $ \_ -> do
_ <- verifyLink "http://127.0.0.1:5000/429grandfinale"
infoReverseAccumulator <- readIORef infoReverseAccumulatorRef
reverse infoReverseAccumulator `shouldBe`
reverse infoReverseAccumulator @?=
[ ("HEAD", tooManyRequests429)
, ("HEAD", serviceUnavailable503)
, ("GET", ok200)
]
]
where
checkLinkAndProgressWithServer mock link progress vrExpectation =
E.bracket (forkIO mock) killThread $ \_ -> do

26
tests/Test/Xrefcheck/TrailingSlashSpec.hs
View File

@ -9,7 +9,8 @@ import Universum
import Fmt (blockListF, pretty, unlinesF)
import System.Directory (doesFileExist)
import Test.Hspec (Spec, describe, expectationFailure, it)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase, assertFailure)
import Xrefcheck.Config
import Xrefcheck.Core
@ -17,25 +18,24 @@ import Xrefcheck.Progress
import Xrefcheck.Scan
import Xrefcheck.Scanners.Markdown
spec :: Spec
spec = do
describe "Trailing forward slash detection" $ do
let config = defConfig GitHub
let format = specificFormatsSupport [markdownSupport (scMarkdown (cScanners config))]
forM_ roots $ \root -> do
it ("All the files within the root \"" <>
root <>
"\" should exist") $ do
test_slash :: TestTree
test_slash = testGroup "Trailing forward slash detection" $
let config = defConfig GitHub
format = specificFormatsSupport [markdownSupport (scMarkdown (cScanners config))]
in roots <&> \root ->
testCase ("All the files within the root \"" <>
root <>
"\" should exist") $ do
(ScanResult _ (RepoInfo repoInfo)) <- allowRewrite False $ \rw ->
scanRepo rw format TraversalConfig{ tcIgnored = [] } root
nonExistentFiles <- lefts <$> forM (keys repoInfo) (\filePath -> do
predicate <- doesFileExist filePath
return $ if predicate
then Right ()
else Left filePath)
then Right ()
else Left filePath)
if null nonExistentFiles
then pass
else expectationFailure $ pretty $ unlinesF
else assertFailure $ pretty $ unlinesF
[ "Expected all filepaths to be valid, but these filepaths do not exist:"
, blockListF nonExistentFiles
]

64
tests/Test/Xrefcheck/URIParsingSpec.hs
View File

@ -9,45 +9,49 @@ module Test.Xrefcheck.URIParsingSpec where
import Universum
import Test.Hspec (Spec, describe, it, shouldReturn)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase, (@?=))
import Text.URI (URI)
import Text.URI.QQ (uri)
import URI.ByteString (URIParseError (..), SchemaError (..))
import URI.ByteString (SchemaError (..), URIParseError (..))
import Xrefcheck.Verify (parseUri, VerifyError (..))
import Xrefcheck.Verify (VerifyError (..), parseUri)
spec :: Spec
spec = do
describe "URI parsing should be successful" $ do
it "Without the special characters in the query strings" do
parseUri' "https://example.com/?q=a&p=b#fragment" `shouldReturn`
Right [uri|https://example.com/?q=a&p=b#fragment|]
test_uri :: [TestTree]
test_uri =
[ testGroup "URI parsing should be successful"
[ testCase "Without the special characters in the query strings" do
parseUri' "https://example.com/?q=a&p=b#fragment" >>=
(@?= Right [uri|https://example.com/?q=a&p=b#fragment|])
parseUri' "https://example.com/path/to/smth?q=a&p=b" >>=
(@?= Right [uri|https://example.com/path/to/smth?q=a&p=b|])
parseUri' "https://example.com/path/to/smth?q=a&p=b" `shouldReturn`
Right [uri|https://example.com/path/to/smth?q=a&p=b|]
, testCase "With the special characters in the query strings" do
parseUri' "https://example.com/?q=[a]&<p>={b}#fragment" >>=
(@?= Right
[uri|https://example.com/?q=%5Ba%5D&%3Cp%3E=%7Bb%7D#fragment|])
it "With the special characters in the query strings" do
parseUri' "https://example.com/?q=[a]&<p>={b}#fragment" `shouldReturn`
Right [uri|https://example.com/?q=%5Ba%5D&%3Cp%3E=%7Bb%7D#fragment|]
parseUri' "https://example.com/path/to/smth?q=[a]&<p>={b}" >>=
(@?= Right
[uri|https://example.com/path/to/smth?q=%5Ba%5D&%3Cp%3E=%7Bb%7D|])
]
, testGroup "URI parsing should be unsuccessful"
[ testCase "With the special characters anywhere else" do
parseUri' "https://exa<mple.co>m/?q=a&p=b#fra{g}ment" >>=
(@?= Left (ExternalResourceInvalidUri MalformedPath))
parseUri' "https://example.com/path/to/smth?q=[a]&<p>={b}" `shouldReturn`
Right [uri|https://example.com/path/to/smth?q=%5Ba%5D&%3Cp%3E=%7Bb%7D|]
parseUri' "https://example.com/pa[t]h/to[/]smth?q=a&p=b" >>=
(@?= Left (ExternalResourceInvalidUri MalformedPath))
describe "URI parsing should be unsuccessful" $ do
it "With the special characters anywhere else" do
parseUri' "https://exa<mple.co>m/?q=a&p=b#fra{g}ment" `shouldReturn`
Left (ExternalResourceInvalidUri MalformedPath)
, testCase "With malformed scheme" do
parseUri' "https//example.com/" >>=
(@?= Left (ExternalResourceInvalidUri $ MalformedScheme MissingColon))
parseUri' "https://example.com/pa[t]h/to[/]smth?q=a&p=b" `shouldReturn`
Left (ExternalResourceInvalidUri MalformedPath)
it "With malformed scheme" do
parseUri' "https//example.com/" `shouldReturn`
Left (ExternalResourceInvalidUri $ MalformedScheme MissingColon)
it "With malformed fragment" do
parseUri' "https://example.com/?q=a&p=b#fra{g}ment" `shouldReturn`
Left (ExternalResourceInvalidUri MalformedFragment)
, testCase "With malformed fragment" do
parseUri' "https://example.com/?q=a&p=b#fra{g}ment" >>=
(@?= Left (ExternalResourceInvalidUri MalformedFragment))
]
]
where
parseUri' :: Text -> IO $ Either VerifyError URI
parseUri' = runExceptT . parseUri

5
tests/Tree.hs Normal file
View File

@ -0,0 +1,5 @@
-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>
--
-- SPDX-License-Identifier: MPL-2.0
{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display -optF --generated-module -optF Tree #-}

4
xrefcheck.nix
View File

@ -15,7 +15,7 @@ let
[ "-Werror" ];
components.tests = {
links-tests = {
ftp-tests = {
build-tools = [ pkgs.vsftpd ];
preCheck = ''
echo "Starting vsftpd..."
@ -25,7 +25,7 @@ let
-olisten_port=2221 \
-olisten=yes \
-oftp_username=$(whoami) \
-oanon_root=${./links-tests/ftp_root} \
-oanon_root=${./ftp-tests/ftp_root} \
-opasv_min_port=2222 \
-ohide_file='{.*}' \
-odeny_file='{.*}' \