krank 0.2.0 → 0.2.1
raw patch · 4 files changed
+139/−101 lines, 4 filesdep ~aesondep ~basedep ~req
Dependency ranges changed: aeson, base, req, text
Files
- README.md +2/−2
- krank.cabal +33/−35
- src/Krank/Checkers/IssueTracker.hs +49/−31
- tests/Test/Krank/Checkers/IssueTrackerSpec.hs +55/−33
README.md view
@@ -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
krank.cabal view
@@ -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
src/Krank/Checkers/IssueTracker.hs view
@@ -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) }
tests/Test/Krank/Checkers/IssueTrackerSpec.hs view
@@ -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)+ ]