mirror of
https://github.com/serokell/xrefcheck.git
synced 2024-08-16 17:10:26 +03:00
[#149] Replace hspec with tasty
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:
parent
955e0ea9cf
commit
b412781020
@ -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
|
||||
|
||||
|
14
package.yaml
14
package.yaml
@ -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
|
||||
|
@ -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
|
||||
|
@ -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 #-}
|
@ -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
|
||||
|
@ -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"
|
||||
)
|
||||
]
|
||||
]
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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]
|
||||
|
@ -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"
|
||||
]
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
]
|
||||
|
@ -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
5
tests/Tree.hs
Normal 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 #-}
|
@ -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='{.*}' \
|
||||
|
Loading…
Reference in New Issue
Block a user