krank (empty) → 0.1.0

raw patch · 14 files changed

+636/−0 lines, 14 filesdep +PyFdep +aesondep +basesetup-changed

Dependencies added: PyF, aeson, base, hspec, krank, megaparsec, mtl, optparse-applicative, replace-megaparsec, req, safe-exceptions, text, unordered-containers, utf8-string

Files

• CHANGELOG.md +6/−0
• HACKING.md +27/−0
• LICENSE +30/−0
• README.md +44/−0
• Setup.hs +2/−0
• app/Main.hs +62/−0
• docs/Checkers/IssueTracker.md +39/−0
• krank.cabal +63/−0
• src/Krank.hs +13/−0
• src/Krank/Checkers/IssueTracker.hs +212/−0
• src/Krank/Formatter.hs +24/−0
• src/Krank/Types.hs +25/−0
• tests/Spec.hs +1/−0
• tests/Test/Krank/Checkers/IssueTrackerSpec.hs +88/−0

@@ -0,0 +1,6 @@+# Revision history for krank++## 0.1.0.0 -- 2019-10-21++* First version. Released on an unsuspecting world.+* Support for Github issues tracking

@@ -0,0 +1,27 @@+Krank is written in Haskell.++# Build with nix/cabal++```+nix-build -A krank+```++Should build the package.++```+nix-shell+```++Will drop you in a shell where you can `cabal v2-build`, `cabal v2-test`, ...++# Build with stack++```+stack build+```++Should work.++# Hacking++Edit code, ensure that test are passing and open a pull request on Github. Thank you ;)

@@ -0,0 +1,30 @@+Copyright (c) 2019, Guillaume Bouchard++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Guillaume Bouchard nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,44 @@+# Krank++Krank checks your code source comments for important markers.++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 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+informations found in the comments:++```bash+$ krank $(git ls-files)++[Info] issue #2733 still Open+    in: NixOS/nix+    file: default.nix:20:20++[Error] issue #6313 is now Closed+    in: bazelbuild/bazel+    file: default.nix:67:11++[Error] issue #22 is now Closed+    in: guibou/PyF+    file: src/Foo.hs:100:4+```++Here `krank` is telling us that our source code links to github+issues which are now closed. Time to remove some workarounds now that upstream issues are fixed!++You can check `krank --help` for a list of options.++# Available checkers++- [IssueTracker](docs/Checkers/IssueTracker.md) is listing Github+  issue linked in comment. Issues which are still Open will be listed+  as info and Closed *issues* are listed as *error*. Convenient to know+  when to remove workarounds.++# Misc++- Krank is available on Hackage, but you can also [build it manually](HACKING.md).+- If you want to contribute or add a new checker, you can read the [Contributions guidelines](CONTRIBUTING.md) or [open an issue](https://github.com/guibou/krank/issues).

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,62 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr)++import Control.Exception.Safe+import Control.Applicative (optional)+import Data.Semigroup ((<>))+import Data.Text (unpack)+import qualified Options.Applicative as Opt+import Options.Applicative ((<**>), many)+import Control.Monad.Reader+import PyF++import Krank+import Krank.Formatter+import Krank.Types++data KrankOpts = KrankOpts {+  codeFilePaths :: [FilePath],+  krankConfig :: KrankConfig+}++filesToParse :: Opt.Parser [FilePath]+filesToParse = many (Opt.argument Opt.str (Opt.metavar "FILES..."))++githubKeyToParse :: Opt.Parser (Maybe GithubKey)+githubKeyToParse = optional (+  GithubKey <$> (+    Opt.strOption $+      Opt.long "issuetracker-githubkey"+      <> Opt.metavar "DEVELOPER_KEY"+      <> Opt.help "A github developer key to allow for more API calls for the IssueTracker checker"))++optionsParser :: Opt.Parser KrankOpts+optionsParser = KrankOpts+  <$> filesToParse+  <*> (KrankConfig+       <$> githubKeyToParse+       <*> (Opt.switch $ Opt.long "dry-run"+        <> Opt.help "Perform a dry run. Parse file, but do not execute HTTP requests")+      )++opts :: Opt.ParserInfo KrankOpts+opts = Opt.info (optionsParser <**> Opt.helper)+  ( Opt.fullDesc+  <> Opt.progDesc "Checks the comments in FILES"+  <> Opt.header "krank - a comment linter / analytics tool" )++runKrank :: FilePath -> KrankConfig -> IO ()+runKrank path options = do+  violations <- runReaderT (processFile path) options+  putStr . unpack . showViolations $ violations++main :: IO ()+main = do+  options <- Opt.execParser opts+  (flip mapM_) (codeFilePaths options) $ \path -> do+    (runKrank path (krankConfig options))+    `catchAnyDeep` (\(SomeException e) -> hPutStrLn stderr [fmt|Error when processing {path}: {show e}|])

@@ -0,0 +1,39 @@+# IssueTracker++## Purpose++Looks for issue tracker references in the codebase. When those are put in comments, it's generally+to signal that some code is there to workaround a library bug/limitation.+This checker will inspect the issue status and warn if the issue mentioned is closed (meaning that+the workaround might be now unnecessary)++## Support++**IssueTracker** currently supports the following list of issue trackers:+* Github++## Configuration++### Github++#### API rate limitation++If you are inspecting a codebase that has many issue references, or if you are running `krank` often+from the same IP, you might hit a Github rate limitation (60 api calls per hour for anonymous+requests).+To circumvent this, you can create a **Personal Access Token** and pass it to `krank` with the+`--issuetracker-githubkey` option. Github API calls will now be authenticated and the rate limit+will be 5000 API calls per hour.+Note that for IssueTracker to be able to report on issues from public repositories, you don't need+to give any scope at all to your **Personal Access Token**.++To generate a **Personal Access Token**, consult [the following documentation](https://help.github.com/en/articles/creating-a-personal-access-token-for-the-command-line)++#### Private repositories++To get information about private repositories, you need to provide Github authentication to the+**IssueTracker** checker.+To do so, you need to generate a **Personal Access Token**+([See+documentation](https://help.github.com/en/articles/creating-a-personal-access-token-for-the-command-line))+with the `repo` scope and pass it to `krank` with the `--issuetracker-githubkey` option

@@ -0,0 +1,63 @@+cabal-version:       >=1.10+name:                krank+version:             0.1.0+synopsis: Krank checks your code source comments for important markers+-- description:+bug-reports: https://github.com/guibou/krank/issues+license: BSD3+license-file:        LICENSE+author:              Guillaume Bouchard+maintainer:          guillaum.bouchard@gmail.com+homepage:            https://github.com/guibou/krank+copyright:+category: quality+description: 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 themselves.+build-type:          Simple+extra-source-files:  CHANGELOG.md, README.md HACKING.md docs/Checkers/IssueTracker.md++library+  exposed-modules:     Krank+                       Krank.Checkers.IssueTracker+                       Krank.Formatter+                       Krank.Types++  build-depends:       base >= 4.9 && < 5.0+                       , aeson >= 1.4.4 && < 1.5+                       , PyF >= 0.8.1.0 && < 0.9+                       , req >= 2.1.0 && < 2.2+                       , text >= 1.2.3 && < 1.3+                       , unordered-containers >= 0.2.10 && < 0.2.11+                       , utf8-string >= 1.0.1.1 && < 1.1+                       , replace-megaparsec+                       , megaparsec+                       , mtl+                       , safe-exceptions+  hs-source-dirs:      src+  ghc-options: -Wall+  default-language:    Haskell2010++test-suite krank-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      tests+  main-is:             Spec.hs+  other-modules:       Test.Krank.Checkers.IssueTrackerSpec+  build-tools:+  build-depends:       base+                       , hspec >= 2.7 && < 2.8+                       , PyF >= 0.8.1.0 && < 0.9+                       , krank+                       , megaparsec+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++executable krank+  main-is:             Main.hs+  build-depends:       base >=4.12 && <4.13+                       , optparse-applicative >= 0.14 && < 0.15+                       , text >= 1.2.3 && < 1.3+                       , krank+                       , PyF+                       , safe-exceptions+                       , mtl+  hs-source-dirs:      app+  default-language:    Haskell2010

@@ -0,0 +1,13 @@+module Krank (+  processFile+  ) where++import qualified Krank.Checkers.IssueTracker as IT+import Krank.Types+import Control.Monad.Reader++processFile :: FilePath      -- ^ the file to analyze+            -> ReaderT KrankConfig IO [Violation]+processFile filePath = do+  content <- liftIO $ readFile filePath+  IT.checkText filePath content

@@ -0,0 +1,212 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DuplicateRecordFields #-}++module Krank.Checkers.IssueTracker (+  GitIssue(..)+  , GitServer(..)+  , Localized(..)+  , checkText+  , extractIssues+  , githubRE+  -- , gitlabRE+  , gitRepoRE+  ) where++import Control.Applicative ((*>), optional)+import Control.Exception.Safe (catch)+import Data.Aeson (Value, (.:))+import qualified Data.Aeson.Types as AesonT+import qualified Data.ByteString.UTF8 as BSU+import Data.Char (isDigit)+import Data.Text (Text, pack)+import qualified Network.HTTP.Req as Req+import PyF (fmt)++import Replace.Megaparsec+import Text.Megaparsec hiding (token)+import Text.Megaparsec.Char+import Data.Void+import Data.Either (rights)+import Control.Monad.Reader++import Krank.Types++data GitServer = Github+  -- Gitlab -- TODO: enable gitlab again+  deriving (Eq, Show)++data IssueStatus = Open | Closed deriving (Eq, Show)++-- | Represents a localized chunk of information+-- in a file+data Localized t = Localized+  { location :: SourcePos+  , unLocalized :: t+  } deriving (Show, Eq)++localized :: Parser t -> Parser (Localized t)+localized p = Localized <$> getSourcePos <*> p++data GitIssue = GitIssue {+  server :: GitServer,+  owner :: Text,+  repo :: Text,+  issueNum :: Int+} deriving (Eq, Show)++data GitIssueWithStatus = GitIssueWithStatus {+  gitIssue :: Localized GitIssue,+  issueStatus :: IssueStatus+} deriving (Eq, Show)++serverDomain :: GitServer+             -> String+serverDomain Github = "github.com"+-- serverDomain Gitlab = "gitlab.com"++type Parser t = Parsec Void String t++githubRE :: Parser GitIssue+githubRE = gitRepoRE Github++-- gitlabRE :: Parser GitIssue+-- gitlabRE = gitRepoRE Gitlab++gitRepoRE :: GitServer+          -> Parser GitIssue+gitRepoRE gitServer = do+  optional ("http" *> optional "s" *> "://")+  optional "www."+  string (serverDomain gitServer)+  "/"+  repoOwner <- some (satisfy ('/'/=))+  "/"+  repoName <- some (satisfy ('/'/=))+  "/"+  "issues/"+  issueNumStr <- some (satisfy isDigit)+  -- Note that read is safe because of the regex parsing+  return $ GitIssue gitServer (pack repoOwner) (pack repoName) (read issueNumStr)++extractIssues+  :: FilePath+  -> String+  -> [Localized GitIssue]+extractIssues filePath toCheck = case parse (findAllCap patterns) filePath toCheck of+  Left _ -> []+  Right res -> map snd $ rights res+  where+    patterns = localized $ choice [+      githubRE+      -- gitlabRE -- TODO: enable gitlab again+      ]++-- Supports only github for the moment+issueUrl :: GitIssue+         -> 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./: (pack . show $ issueNum issue)+  -- Gitlab -> Req.https "google.com"++-- try Issue can fail, on non-2xx HTTP response+tryRestIssue :: Req.Url 'Req.Https+             -> ReaderT KrankConfig IO Value+tryRestIssue url = do+  mGithubKey <- githubKey <$> ask+  let+    authHeaders = case mGithubKey of+      Just (GithubKey token) -> Req.oAuth2Token (BSU.fromString token)+      Nothing -> mempty++  Req.runReq Req.defaultHttpConfig $ do+    r <- Req.req Req.GET url Req.NoReqBody Req.jsonResponse (+      Req.header "User-Agent" "krank"+      <> authHeaders)+    pure $ Req.responseBody r+++httpExcHandler :: Req.Url 'Req.Https+               -> Req.HttpException+               -> ReaderT KrankConfig IO Value+httpExcHandler url _ = pure . AesonT.object $ [("error", AesonT.String . pack . show $ url)]++restIssue :: Req.Url 'Req.Https+          -> ReaderT KrankConfig IO Value+restIssue url = catch (tryRestIssue url) (httpExcHandler url)++statusParser :: Value+            -> Either Text IssueStatus+statusParser (AesonT.Object o) = do+  let state :: AesonT.Result String = AesonT.parse (.: "state") o+  readState state+    where+      readState (AesonT.Success status) = case status of+        "closed" -> Right Closed+        "open"   -> Right Open+        _        -> Left [fmt|Could not parse status '{status}'|]+      readState (AesonT.Error _) = Left $ errorParser o+statusParser _ = Left "invalid JSON"++errorParser :: AesonT.Object+            -> Text+errorParser o = do+  let err = AesonT.parse (.: "error") o+  readErr err+    where+      readErr (AesonT.Success errText) = pack errText+      readErr (AesonT.Error _) = "invalid JSON"++gitIssuesWithStatus :: [Localized GitIssue]+                    -> ReaderT KrankConfig IO [Either (Text, Localized GitIssue) GitIssueWithStatus]+gitIssuesWithStatus issues = do+  isDryRun <- dryRun <$> ask++  if isDryRun+    then do+      pure $ map (\c -> Left ("Dry run", c)) issues+    else do+    let urls = issueUrl . unLocalized <$> issues+    statuses <- mapM restIssue urls+    pure $ zipWith f issues (fmap statusParser statuses)+      where+        f issue (Left err) = Left (err, issue)+        f issue (Right is) = Right $ GitIssueWithStatus issue is++issueTrackerChecker :: Text+issueTrackerChecker = "GIT Issue Tracker"++issueToLevel :: GitIssueWithStatus+             -> ViolationLevel+issueToLevel i = case issueStatus i of+  Open   -> Info+  Closed -> Error++issueToSnippet :: GitIssueWithStatus+               -> Text+issueToSnippet i = [fmt|{owner issue}/{repo issue}|]+  where+    issue = unLocalized $ gitIssue i++issueToMessage :: GitIssueWithStatus+               -> Text+issueToMessage i = case issueStatus i of+  Open   -> [fmt|issue #{issueNum issue} still Open|]+  Closed -> [fmt|issue #{issueNum issue} is now Closed|]+  where+    issue = unLocalized $ gitIssue i++checkText :: FilePath+          -> String+          -> ReaderT KrankConfig IO [Violation]+checkText path t = do+  let issues = extractIssues path t+  issuesWithStatus <- gitIssuesWithStatus issues+  pure $ fmap f issuesWithStatus+    where+      f (Left (err, issue)) = Violation issueTrackerChecker Warning "Url could not be reached" err (location (issue :: Localized GitIssue))+      f (Right issue) = Violation issueTrackerChecker (issueToLevel issue) (issueToSnippet issue) (issueToMessage issue) (location ((gitIssue issue) :: Localized GitIssue))

@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Krank.Formatter (+  showViolations+  ) where++import Data.Text (Text)+import PyF (fmt)+import Text.Megaparsec.Pos (sourcePosPretty)++import Krank.Types++showViolations :: [Violation]+               -> Text+showViolations = foldMap showViolation++showViolation :: Violation+              -> Text+showViolation violation = [fmt|+[{(show (level violation))}] {message violation}+    in: {snippet violation}+    file: {sourcePosPretty (location violation)}+|]

@@ -0,0 +1,25 @@+module Krank.Types (+  GithubKey(..)+  , Violation(..)+  , ViolationLevel(..)+  , KrankConfig(..)+  ) where++import Data.Text (Text)+import Text.Megaparsec (SourcePos)++newtype GithubKey = GithubKey String++data ViolationLevel = Info | Warning | Error deriving (Show)++data Violation = Violation { checker :: Text+                           , level :: ViolationLevel+                           , snippet :: Text+                           , message :: Text+                           , location :: SourcePos+                           } deriving (Show)++data KrankConfig = KrankConfig+  { githubKey :: Maybe GithubKey+  , dryRun :: Bool+  }

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

@@ -0,0 +1,88 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Test.Krank.Checkers.IssueTrackerSpec (+  spec+  ) where++import PyF (fmt)+import Test.Hspec++import Krank.Checkers.IssueTracker+import Text.Megaparsec (parseMaybe, Parsec)+import Data.Void+import Text.Megaparsec.Pos (SourcePos(..), mkPos)++-- | Alias for fast parsing+(=~) :: String -> Parsec Void String GitIssue -> Maybe GitIssue+url =~ parser = parseMaybe parser url++spec :: Spec+spec =+  context "Test.Krank.Checkers.specIssueTracker" $ do+    describe "#githubRE" $ do+      it "handles full https url" $ do+        let match = "https://github.com/guibou/krank/issues/1" =~ githubRE+        match `shouldBe` (Just $ GitIssue Github "guibou" "krank" 1)++      it "handles full http url" $ do+        let match = "http://github.com/guibou/krank/issues/1" =~ githubRE+        match `shouldBe` (Just $ GitIssue Github "guibou" "krank" 1)++      it "handles short url - no protocol" $ do+        let match = "github.com/guibou/krank/issues/1" =~ githubRE+        match `shouldBe` (Just $ GitIssue Github "guibou" "krank" 1)++      it "accepts www in url" $ do+        let match = "https://www.github.com/guibou/krank/issues/1" =~ githubRE+        match `shouldBe` (Just $ GitIssue Github "guibou" "krank" 1)++      it "accepts www in url - no protocol" $ do+        let match = "www.github.com/guibou/krank/issues/1" =~ githubRE+        match `shouldBe` (Just $ GitIssue Github "guibou" "krank" 1)++      it "fails if the issue number is not an int" $ do+        let match = "github.com/guibou/krank/issues/foo" =~ githubRE+        match `shouldBe` Nothing++      it "fails if there are too many components in the path" $ do+        let match = "github.com/guibou/krank/should_not_be_here/issues/1" =~ githubRE+        match `shouldBe` Nothing++      it "fails if github not in path" $ do+        let match = "google.com/guibou/krank/issues/1" =~ githubRE+        match `shouldBe` Nothing++      it "fails if not a github issue" $ do+        let match = "github.com/guibou/krank/branches/1" =~ githubRE+        match `shouldBe` Nothing++      it "fails on partial match" $ do+        let match = "github.com/guibou/krank/" =~ githubRE+        match `shouldBe` Nothing++      it "fails on partial match (just missing the issue number)" $ do+        let match = "github.com/guibou/krank/issues/" =~ githubRE+        match `shouldBe` Nothing++    -- describe "#gitlabRE" $+    --   it "handles full https url" $ do+    --     let match = "https://gitlab.com/gitlab-org/gitlab-foss/issues/67390" =~ gitlabRE+    --     match `shouldBe` (Just $ GitIssue Gitlab "gitlab-org" "gitlab-foss" 67390)++    describe "#githubRE" $+      it "handles full https url" $ do+        let match = "https://github.com/guibou/krank/issues/2" =~ githubRE+        match `shouldBe` (Just $ GitIssue Github "guibou" "krank" 2)++    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+        |]+        match `shouldMatchList` [+          Localized (SourcePos "localFile" (mkPos 1) (mkPos 1)) $ GitIssue Github "guibou" "krank" 2+          -- , Localized (SourcePos "localFile" (mkPos 3) (mkPos 17)) $ GitIssue Gitlab "gitlab-org" "gitlab-foss" 67390+          , Localized (SourcePos "localFile" (mkPos 4) (mkPos 25)) $ GitIssue Github "guibou" "krank" 1 ]