diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,13 +7,13 @@ Comments are part of our code and are not usually tested correctly. Hence their content can become incoherent or -obsolete. Krank tries to avoid that by running checkers on the comment +obsolete. Krank tries to avoid that by running checkers on the comments themselves. # Usage Just launch the `krank` command with a list of files as arguments. It -works on any kind of source code file and print a reports of +works on any kind of source code file and prints a report of informations found in the comments: ```bash diff --git a/krank.cabal b/krank.cabal --- a/krank.cabal +++ b/krank.cabal @@ -1,10 +1,10 @@ -cabal-version: >=1.10 +cabal-version: 2.2 name: krank -version: 0.2.0 +version: 0.2.1 synopsis: Krank checks your code source comments for important markers -- description: bug-reports: https://github.com/guibou/krank/issues -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Guillaume Bouchard maintainer: guillaum.bouchard@gmail.com @@ -15,17 +15,7 @@ build-type: Simple extra-source-files: CHANGELOG.md, README.md HACKING.md docs/Checkers/IssueTracker.md -library - exposed-modules: Krank - Krank.Checkers.Ignore - Krank.Checkers.IssueTracker - Krank.Formatter - Krank.Types - Utils.Display - Utils.Github - Utils.Gitlab - Utils.Req - +common shared-library build-depends: base >= 4.9 , PyF >= 0.8.1.0 , aeson >= 1.4.4 @@ -42,36 +32,44 @@ , text >= 1.2.3 , unordered-containers >= 0.2.10 hs-source-dirs: src + ghc-options: -Wall default-language: Haskell2010 +library + import: shared-library + exposed-modules: Krank + Krank.Checkers.Ignore + Krank.Checkers.IssueTracker + Krank.Formatter + Krank.Types + Utils.Display + Utils.Github + Utils.Gitlab + Utils.Req + test-suite krank-test + import: shared-library + type: exitcode-stdio-1.0 - hs-source-dirs: tests main-is: Spec.hs + + hs-source-dirs: tests other-modules: Test.Krank.Checkers.IssueTrackerSpec Test.Utils.GithubSpec Test.Utils.GitlabSpec - build-tools: - build-depends: base >= 4.9 && <= 5.0 - , PyF >= 0.8.1.0 - , aeson - , bytestring - , containers - , hspec >= 2.7 - , hspec-expectations - , http-client >= 0.6 - , http-types >= 0.12 - , krank - , mtl - , pcre-heavy - , req - , req >= 2.1.0 - , safe-exceptions - , text - , unordered-containers >= 0.2.10 - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N - default-language: Haskell2010 + Krank + Krank.Checkers.Ignore + Krank.Checkers.IssueTracker + Krank.Formatter + Krank.Types + Utils.Display + Utils.Github + Utils.Gitlab + Utils.Req + build-depends: hspec >= 2.7 + , hspec-expectations + ghc-options: -threaded -rtsopts -with-rtsopts=-N executable krank main-is: Main.hs diff --git a/src/Krank/Checkers/IssueTracker.hs b/src/Krank/Checkers/IssueTracker.hs --- a/src/Krank/Checkers/IssueTracker.hs +++ b/src/Krank/Checkers/IssueTracker.hs @@ -8,7 +8,7 @@ {-# LANGUAGE ViewPatterns #-} module Krank.Checkers.IssueTracker - ( GitIssue (..), + ( GitIssueRef (..), GitServer (..), Localized (..), checkText, @@ -39,8 +39,8 @@ data IssueStatus = Open | Closed deriving (Eq, Show) -data GitIssue - = GitIssue +data GitIssueRef + = GitIssueRef { server :: GitServer, owner :: Text, repo :: Text, @@ -48,10 +48,11 @@ } deriving (Eq, Show) -data GitIssueWithStatus - = GitIssueWithStatus - { gitIssue :: Localized GitIssue, - issueStatus :: IssueStatus +data GitIssueData + = GitIssueData + { gitIssue :: Localized GitIssueRef, + issueStatus :: IssueStatus, + issueTitle :: Text } deriving (Eq, Show) @@ -65,13 +66,13 @@ gitRepoRe :: RE.Regex -- NOTE: \b at the beginning is really import for performances -- because it dramatically reduces the number of backtracks -gitRepoRe = [RE.re|\b(?>https?://)?(?>www\.)?([^/ ]+)/(.*)/([^-][^/]*)(?>/-)?/issues/([0-9]+)|] +gitRepoRe = [RE.re|\b(?>https?://)?(?>www\.)?([^/ ]+)/([^ ]+)/([^- ][^/ ]*)(?>/-)?/issues/([0-9]+)|] -- | Extract all issues on one line and returns a list of the raw text associated with an issue -extractIssuesOnALine :: ByteString -> [(Int, GitIssue)] +extractIssuesOnALine :: ByteString -> [(Int, GitIssueRef)] extractIssuesOnALine lineContent = map f (RE.scan gitRepoRe lineContent) where - f (match, [domain, owner, repo, ByteString.readInt -> Just (issueNo, _)]) = (colNo, GitIssue provider (Text.Encoding.decodeUtf8 owner) (Text.Encoding.decodeUtf8 repo) issueNo) + f (match, [domain, owner, repo, ByteString.readInt -> Just (issueNo, _)]) = (colNo, GitIssueRef provider (Text.Encoding.decodeUtf8 owner) (Text.Encoding.decodeUtf8 repo) issueNo) where colNo = 1 + ByteString.length (fst $ ByteString.breakSubstring match lineContent) provider @@ -97,7 +98,7 @@ FilePath -> -- | Content of the file ByteString -> - [Localized GitIssue] + [Localized GitIssueRef] extractIssues filePath toCheck = concat (zipWith extract [1 ..] (ByteString.lines toCheck)) where extract lineNo lineContent = map f (extractIssuesOnALine lineContent) @@ -106,7 +107,7 @@ -- Supports only github for the moment issueUrl :: - GitIssue -> + GitIssueRef -> Req.Url 'Req.Https issueUrl issue = case server issue of Github -> Req.https "api.github.com" Req./: "repos" Req./: owner issue Req./: repo issue Req./: "issues" Req./~ issueNum issue @@ -115,7 +116,7 @@ -- try Issue can fail, on non-2xx HTTP response tryRestIssue :: MonadKrank m => - Localized GitIssue -> + Localized GitIssueRef -> m Value tryRestIssue locIssue = do let issue = unLocalized locIssue @@ -125,7 +126,7 @@ headersFor :: MonadKrank m => - GitIssue -> + GitIssueRef -> m (Req.Option 'Req.Https) headersFor issue = do mGithubKey <- krankAsks githubKey @@ -155,7 +156,7 @@ restIssue :: MonadKrank m => - Localized GitIssue -> + Localized GitIssueRef -> m Value restIssue issue = catch (tryRestIssue issue) (httpExcHandler . server . unLocalized $ issue) @@ -174,6 +175,17 @@ readState (AesonT.Error _) = Left $ errorParser o statusParser _ = Left "invalid JSON" +titleParser :: + Value -> + Either Text Text +titleParser (AesonT.Object o) = do + let title :: AesonT.Result String = AesonT.parse (.: "title") o + Right $ readTitle title + where + readTitle (AesonT.Success title) = pack title + readTitle (AesonT.Error _) = "invalid JSON" +titleParser _ = Left "invalid JSON" + errorParser :: AesonT.Object -> Text @@ -186,31 +198,37 @@ gitIssuesWithStatus :: MonadKrank m => - [Localized GitIssue] -> - m [Either (Text, Localized GitIssue) GitIssueWithStatus] + [Localized GitIssueRef] -> + m [Either (Text, Localized GitIssueRef) GitIssueData] gitIssuesWithStatus issues = do - statuses <- krankMapConcurrently restIssue issues - pure $ zipWith f issues (fmap statusParser statuses) + jsonData <- krankMapConcurrently restIssue issues + let statuses = fmap statusParser jsonData + let titles = fmap titleParser jsonData + pure $ zipWith3 f issues statuses titles where - f issue (Left err) = Left (err, issue) - f issue (Right is) = Right $ GitIssueWithStatus issue is + f issue (Left err) _ = Left (err, issue) + f issue _ (Left err) = Left (err, issue) + f issue (Right status) (Right title) = Right $ GitIssueData issue status title issueToLevel :: - GitIssueWithStatus -> + GitIssueData -> ViolationLevel issueToLevel i = case issueStatus i of Open -> Info Closed -> Error issueToMessage :: - GitIssueWithStatus -> + GitIssueData -> Text -issueToMessage i = case issueStatus i of - Open -> [fmt|still Open|] - Closed -> [fmt|now Closed - You can remove the workaround you used there|] +issueToMessage i = + case issueStatus i of + Open -> [fmt|the issue is still Open\ntitle: {title}|] + Closed -> [fmt|the issue is now Closed - You can remove the workaround you used there\ntitle: {title}|] + where + title = issueTitle i -issuePrintUrl :: GitIssue -> Text -issuePrintUrl GitIssue {owner, repo, server, issueNum} = [fmt|IssueTracker check for https://{serverDomain server}/{owner}/{repo}/issues/{issueNum}|] +issuePrintUrl :: GitIssueRef -> Text +issuePrintUrl GitIssueRef {owner, repo, server, issueNum} = [fmt|IssueTracker check for https://{serverDomain server}/{owner}/{repo}/issues/{issueNum}|] checkText :: MonadKrank m => @@ -229,7 +247,7 @@ { checker = issuePrintUrl . unLocalized $ issue, level = Info, message = "Dry run", - location = getLocation (issue :: Localized GitIssue) + location = getLocation (issue :: Localized GitIssueRef) } ) issues @@ -242,12 +260,12 @@ { checker = issuePrintUrl . unLocalized $ issue, level = Warning, message = "Error when calling the API:\n" <> err, - location = getLocation (issue :: Localized GitIssue) + location = getLocation (issue :: Localized GitIssueRef) } f (Right issue) = Violation { checker = issuePrintUrl (unLocalized . gitIssue $ issue), level = issueToLevel issue, message = issueToMessage issue, - location = getLocation (gitIssue issue :: Localized GitIssue) + location = getLocation (gitIssue issue :: Localized GitIssueRef) } diff --git a/tests/Test/Krank/Checkers/IssueTrackerSpec.hs b/tests/Test/Krank/Checkers/IssueTrackerSpec.hs --- a/tests/Test/Krank/Checkers/IssueTrackerSpec.hs +++ b/tests/Test/Krank/Checkers/IssueTrackerSpec.hs @@ -65,7 +65,7 @@ Data.Aeson.Error s -> throw (Req.JsonHttpException s) Left exception -> throw exception -check :: ByteString -> Maybe GitIssue +check :: ByteString -> Maybe GitIssueRef check a = case extractIssuesOnALine a of [(_, x)] -> Just x _ -> Nothing @@ -75,19 +75,19 @@ 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) + match `shouldBe` Just (GitIssueRef 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) + match `shouldBe` Just (GitIssueRef 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) + match `shouldBe` Just (GitIssueRef 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) + match `shouldBe` Just (GitIssueRef 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) + match `shouldBe` Just (GitIssueRef 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 @@ -99,13 +99,13 @@ 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) + match `shouldBe` Just (GitIssueRef 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) + match `shouldBe` Just (GitIssueRef 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) + match `shouldBe` Just (GitIssueRef domain "gbataille_main/sub_level_1/sub_level_2" "deep_in_groups" 12) spec :: Spec spec = do @@ -127,10 +127,10 @@ 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 + `shouldMatchList` [ Localized (SourcePos "localFile" 1 1) $ GitIssueRef Github "guibou" "krank" 2, + Localized (SourcePos "localFile" 3 9) $ GitIssueRef (Gitlab (GitlabHost "gitlab.com")) "gitlab-org" "gitlab-foss" 67390, + Localized (SourcePos "localFile" 4 25) $ GitIssueRef Github "guibou" "krank" 1, + Localized (SourcePos "localFile" 5 16) $ GitIssueRef (Gitlab (GitlabHost "gitlab.haskell.org")) "ghc" "ghc" 16955 ] describe "huge test" $ do let config = @@ -140,38 +140,42 @@ dryRun = False, useColors = False } - env state10 = + env state10 title10 title11 = 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")]) + [ (Req.https "api.github.com" Req./: "repos" Req./: "foo" Req./: "bar" Req./: "issues" Req./: "10", Right $ object [("state", String state10), ("title", String title10)]), + (Req.https "api.github.com" Req./: "repos" Req./: "foo" Req./: "bar" Req./: "issues" Req./: "11", Right $ object [("state", String "open"), ("title", String title11)]) ] } it "should work" $ do - let Right res = runReaderT (runWriterT (unTestKrank $ runKrank ["foo", "bar"])) (env "closed", config) + let firstIssueTitle = "fooobar" + let secondIssueTitle = "barbaz" + let Right res = runReaderT (runWriterT (unTestKrank $ runKrank ["foo", "bar"])) (env "closed" firstIssueTitle secondIssueTitle, 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] + ( [[fmt|\nfoo:1:12: error:\n IssueTracker check for https://github.com/foo/bar/issues/10\n the issue is now Closed - You can remove the workaround you used there\n | title: {firstIssueTitle}\n\nfoo:2:1: info:\n IssueTracker check for https://github.com/foo/bar/issues/11\n the issue is still Open\n | title: {secondIssueTitle}\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) + let firstIssueTitle = "barbouze" + let secondIssueTitle = "bouya" + let Right res = runReaderT (runWriterT (unTestKrank $ runKrank ["foo"])) (env "closed" firstIssueTitle secondIssueTitle, 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"], + ( [[fmt|\nfoo:1:12: error:\n IssueTracker check for https://github.com/foo/bar/issues/10\n the issue is now Closed - You can remove the workaround you used there\n | title: {firstIssueTitle}\n\nfoo:2:1: info:\n IssueTracker check for https://github.com/foo/bar/issues/11\n the issue is still Open\n | title: {secondIssueTitle}\n|]], [] :: [Text] ) ) it "with error in file" $ do - let Right res = runReaderT (runWriterT (unTestKrank $ runKrank ["foo", "bar"])) (env "open", config) + let firstIssueTitle = "yazu" + let secondIssueTitle = "zuma" + let Right res = runReaderT (runWriterT (unTestKrank $ runKrank ["foo", "bar"])) (env "open" firstIssueTitle secondIssueTitle, 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], + ( [[fmt|\nfoo:1:12: info:\n IssueTracker check for https://github.com/foo/bar/issues/10\n the issue is still Open\n | title: {firstIssueTitle}\n\nfoo:2:1: info:\n IssueTracker check for https://github.com/foo/bar/issues/11\n the issue is still Open\n | title: {secondIssueTitle}\n|]] :: [Text], [ "Error when processing bar: user error (file not found)" ] :: [Text] @@ -182,37 +186,55 @@ -- 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) + let firstIssueTitle = "malaria" + let secondIssueTitle = "ria riu rio" + let Right res = runReaderT (runWriterT (unTestKrank $ runKrank ["foo"])) (env "open" firstIssueTitle secondIssueTitle, 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], + ( [[fmt|\nfoo:1:12: info:\n IssueTracker check for https://github.com/foo/bar/issues/10\n the issue is still Open\n | title: {firstIssueTitle}\n\nfoo:2:1: info:\n IssueTracker check for https://github.com/foo/bar/issues/11\n the issue is still Open\n | title: {secondIssueTitle}\n|]] :: [Text], [] :: [Text] ) ) it "ignore are ignored" $ do - let config = + let firstIssueTitle = "rio del mare" + let secondIssueTitle = "margulin" + let testConfig = KrankConfig { githubKey = Nothing, gitlabKeys = Map.empty, dryRun = False, useColors = False } - env = + testEnv = 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")]) + [ (Req.https "api.github.com" Req./: "repos" Req./: "foo" Req./: "bar" Req./: "issues" Req./: "10", Right $ object [("state", String "closed"), ("title", String firstIssueTitle)]), + (Req.https "api.github.com" Req./: "repos" Req./: "foo" Req./: "bar" Req./: "issues" Req./: "11", Right $ object [("state", String "open"), ("title", String secondIssueTitle)]) ] } - let Right res = runReaderT (runWriterT (unTestKrank $ runKrank ["foo", "bar"])) (env, config) + let Right res = runReaderT (runWriterT (unTestKrank $ runKrank ["foo", "bar"])) (testEnv, testConfig) -- 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], + ( [[fmt|\nfoo:2:1: info:\n IssueTracker check for https://github.com/foo/bar/issues/11\n the issue is still Open\n | title: {secondIssueTitle}\n|]] :: [Text], [ "Error when processing bar: user error (file not found)" ] :: [Text] ) ) + describe "it parses when there is two url on the same line" $ do + it "works correctly with only one in second position" $ do + extractIssues "foo" "https://ip.tyk.nu https://github.com/x/x/issues/32" + `shouldBe` [ Localized (SourcePos "foo" 1 19) (GitIssueRef Github "x" "x" 32) + ] + it "works correctly with only one in first position" $ do + extractIssues "foo" "foo bar baz https://github.com/x/x/issues/32 https://ip.tyk.nu" + `shouldBe` [ Localized (SourcePos "foo" 1 13) (GitIssueRef Github "x" "x" 32) + ] + it "works correctly with two correct url" $ do + extractIssues "foo" "foo gitlab.com/foo/br/issues/10 https://github.com/x/x/issues/32 https://ip.tyk.nu" + `shouldBe` [ Localized (SourcePos "foo" 1 5) (GitIssueRef (Gitlab (GitlabHost "gitlab.com")) "foo" "br" 10), + Localized (SourcePos "foo" 1 33) (GitIssueRef Github "x" "x" 32) + ]