krank-0.2.0: tests/Test/Krank/Checkers/IssueTrackerSpec.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Test.Krank.Checkers.IssueTrackerSpec
( spec,
)
where
import Control.Exception.Safe (MonadCatch, MonadThrow, SomeException, throw)
import Control.Monad.Reader
import Control.Monad.Writer
import Data.Aeson (Result (..), Value (..), fromJSON, object)
import Data.ByteString (ByteString)
import Data.Coerce
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text
import Krank
import Krank.Checkers.IssueTracker
import Krank.Types
import qualified Network.HTTP.Req as Req
import PyF (fmt)
import Test.Hspec
data TestEnv
= TestEnv
{ envFiles :: Map FilePath Data.ByteString.ByteString,
envRestAnswers :: Map (Req.Url 'Req.Https) (Either Req.HttpException Value)
}
newtype TestKrank t
= TestKrank
{ unTestKrank :: WriterT ([Text], [Text]) (ReaderT (TestEnv, KrankConfig) (Either SomeException)) t
}
deriving newtype (Monad, Applicative, Functor, MonadThrow, MonadCatch)
-- | "pure" instance of 'MonadKrank'
-- It works on a 'TestEnv'.
instance MonadKrank TestKrank where
krankPutStrLnStderr t = TestKrank $ tell ([], [t])
krankPutStr t = TestKrank $ tell ([t], [])
krankAsks f = TestKrank $ asks (f . snd)
krankMapConcurrently f l = TestKrank $ mapM (coerce . f) l
krankReadFile path = TestKrank $ do
files <- asks (envFiles . fst)
case Map.lookup path files of
Nothing -> throw (userError "file not found")
Just c -> pure c
-- Note: options are ignored
krankRunRESTRequest url _options = TestKrank $ do
restAnswers <- asks (envRestAnswers . fst)
case Map.lookup url restAnswers of
Nothing -> error ("Answer not specified for this query: " <> show url)
Just a -> case a of
Right json -> case fromJSON json of
Success res -> pure res
Data.Aeson.Error s -> throw (Req.JsonHttpException s)
Left exception -> throw exception
check :: ByteString -> Maybe GitIssue
check a = case extractIssuesOnALine a of
[(_, x)] -> Just x
_ -> Nothing
giturlTests :: GitServer -> Spec
giturlTests domain = do
let domainName = serverDomain domain
it "handles full https url" $ do
let match = check [fmt|https://{domainName}/guibou/krank/issues/2|]
match `shouldBe` Just (GitIssue domain "guibou" "krank" 2)
it "handles full http url" $ do
let match = check [fmt|http://{domainName}/guibou/krank/issues/1|]
match `shouldBe` Just (GitIssue domain "guibou" "krank" 1)
it "handles short url - no protocol" $ do
let match = check [fmt|{domainName}/guibou/krank/issues/1|]
match `shouldBe` Just (GitIssue domain "guibou" "krank" 1)
it "accepts www. in url" $ do
let match = check [fmt|https://www.{domainName}/guibou/krank/issues/1|]
match `shouldBe` Just (GitIssue domain "guibou" "krank" 1)
it "accepts www in url - no protocol" $ do
let match = check [fmt|www.{domainName}/guibou/krank/issues/1|]
match `shouldBe` Just (GitIssue domain "guibou" "krank" 1)
it "fails if the issue number is not an int" $ do
let match = check [fmt|{domainName}/guibou/krank/issues/foo|]
match `shouldBe` Nothing
it "fails on partial match" $ do
let match = check [fmt|{domainName}/guibou/krank/|]
match `shouldBe` Nothing
it "fails on partial match (just missing the issue number)" $ do
let match = check [fmt|{domainName}/guibou/krank/issues/|]
match `shouldBe` Nothing
it "handles the odd /- in gitlab URL" $ do
let match = check [fmt|{domainName}/guibou/krank/-/issues/3|]
match `shouldBe` Just (GitIssue domain "guibou" "krank" 3)
it "handles long gitlab url with groups" $ do
let match = check [fmt|{domainName}/gbataille_main/sub_level_1/sub_level_2/deep_in_groups/issues/3|]
match `shouldBe` Just (GitIssue domain "gbataille_main/sub_level_1/sub_level_2" "deep_in_groups" 3)
it "handles long gitlab url with groups and with the odd /-" $ do
let match = check [fmt|{domainName}/gbataille_main/sub_level_1/sub_level_2/deep_in_groups/-/issues/12|]
match `shouldBe` Just (GitIssue domain "gbataille_main/sub_level_1/sub_level_2" "deep_in_groups" 12)
spec :: Spec
spec = do
context "Test.Krank.Checkers.specIssueTracker" $ do
describe "#githubParser" $
giturlTests Github
describe "#githlabParser" $
giturlTests (Gitlab (GitlabHost "gitlab.com"))
describe "#extractIssues"
$ it "handles both github and gitlab"
$ do
let match =
extractIssues
"localFile"
[fmt|https://github.com/guibou/krank/issues/2
some text
https://gitlab.com/gitlab-org/gitlab-foss/issues/67390
and more github https://github.com/guibou/krank/issues/1
lalala https://gitlab.haskell.org/ghc/ghc/issues/16955
|]
match
`shouldMatchList` [ Localized (SourcePos "localFile" 1 1) $ GitIssue Github "guibou" "krank" 2,
Localized (SourcePos "localFile" 3 9) $ GitIssue (Gitlab (GitlabHost "gitlab.com")) "gitlab-org" "gitlab-foss" 67390,
Localized (SourcePos "localFile" 4 25) $ GitIssue Github "guibou" "krank" 1,
Localized (SourcePos "localFile" 5 16) $ GitIssue (Gitlab (GitlabHost "gitlab.haskell.org")) "ghc" "ghc" 16955
]
describe "huge test" $ do
let config =
KrankConfig
{ githubKey = Nothing,
gitlabKeys = Map.empty,
dryRun = False,
useColors = False
}
env state10 =
TestEnv
{ envFiles = Map.singleton "foo" " hello you https://github.com/foo/bar/issues/10 yeah\nhttps://github.com/foo/bar/issues/11",
envRestAnswers =
Map.fromList
[ (Req.https "api.github.com" Req./: "repos" Req./: "foo" Req./: "bar" Req./: "issues" Req./: "10", Right $ object [("state", String state10)]),
(Req.https "api.github.com" Req./: "repos" Req./: "foo" Req./: "bar" Req./: "issues" Req./: "11", Right $ object [("state", String "open")])
]
}
it "should work" $ do
let Right res = runReaderT (runWriterT (unTestKrank $ runKrank ["foo", "bar"])) (env "closed", config)
res
`shouldBe` ( False,
( ["\nfoo:1:12: error:\n IssueTracker check for https://github.com/foo/bar/issues/10\n now Closed - You can remove the workaround you used there\n\nfoo:2:1: info:\n IssueTracker check for https://github.com/foo/bar/issues/11\n still Open\n"] :: [Text],
[ "Error when processing bar: user error (file not found)"
] ::
[Text]
)
)
it "with error in url" $ do
let Right res = runReaderT (runWriterT (unTestKrank $ runKrank ["foo"])) (env "closed", config)
res
`shouldBe` ( False,
( ["\nfoo:1:12: error:\n IssueTracker check for https://github.com/foo/bar/issues/10\n now Closed - You can remove the workaround you used there\n\nfoo:2:1: info:\n IssueTracker check for https://github.com/foo/bar/issues/11\n still Open\n"],
[] :: [Text]
)
)
it "with error in file" $ do
let Right res = runReaderT (runWriterT (unTestKrank $ runKrank ["foo", "bar"])) (env "open", config)
res
`shouldBe` ( False,
( ["\nfoo:1:12: info:\n IssueTracker check for https://github.com/foo/bar/issues/10\n still Open\n\nfoo:2:1: info:\n IssueTracker check for https://github.com/foo/bar/issues/11\n still Open\n"] :: [Text],
[ "Error when processing bar: user error (file not found)"
] ::
[Text]
)
)
-- Note: it only tests the semantic of top level function.
-- We need integratino tests wich ensures that the final function
-- works correctly.
-- Or we need to move more things inside the Krank monad, such as "exitFailure".
it "without error" $ do
let Right res = runReaderT (runWriterT (unTestKrank $ runKrank ["foo"])) (env "open", config)
res
`shouldBe` ( True,
( ["\nfoo:1:12: info:\n IssueTracker check for https://github.com/foo/bar/issues/10\n still Open\n\nfoo:2:1: info:\n IssueTracker check for https://github.com/foo/bar/issues/11\n still Open\n"] :: [Text],
[] :: [Text]
)
)
it "ignore are ignored" $ do
let config =
KrankConfig
{ githubKey = Nothing,
gitlabKeys = Map.empty,
dryRun = False,
useColors = False
}
env =
TestEnv
{ envFiles = Map.singleton "foo" " hello you https://github.com/foo/bar/issues/10 yeah# krank:ignore-line\nhttps://github.com/foo/bar/issues/11",
envRestAnswers =
Map.fromList
[ (Req.https "api.github.com" Req./: "repos" Req./: "foo" Req./: "bar" Req./: "issues" Req./: "10", Right $ object [("state", String "closed")]),
(Req.https "api.github.com" Req./: "repos" Req./: "foo" Req./: "bar" Req./: "issues" Req./: "11", Right $ object [("state", String "open")])
]
}
let Right res = runReaderT (runWriterT (unTestKrank $ runKrank ["foo", "bar"])) (env, config)
-- TODO: perhaps ignored lines must appears in the listing, but not as error
res
`shouldBe` ( False,
( ["\nfoo:2:1: info:\n IssueTracker check for https://github.com/foo/bar/issues/11\n still Open\n"] :: [Text],
[ "Error when processing bar: user error (file not found)"
] ::
[Text]
)
)