krank 0.1.0 → 0.2.0

raw patch · 19 files changed

+1270/−350 lines, 19 filesdep +bytestringdep +containersdep +hspec-expectationsdep −megaparsecdep −replace-megaparsecdep −utf8-stringdep ~PyFdep ~aesondep ~basesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, containers, hspec-expectations, http-client, http-types, lifted-async, pcre-heavy, pretty-terminal

Dependencies removed: megaparsec, replace-megaparsec, utf8-string

Dependency ranges changed: PyF, aeson, base, hspec, optparse-applicative, req, text, unordered-containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−0
• HACKING.md +4/−0
• README.md +33/−19
• Setup.hs +1/−0
• app/Main.hs +74/−43
• docs/Checkers/IssueTracker.md +10/−0
• krank.cabal +46/−20
• src/Krank.hs +89/−8
• src/Krank/Checkers/Ignore.hs +75/−0
• src/Krank/Checkers/IssueTracker.hs +201/−160
• src/Krank/Formatter.hs +30/−15
• src/Krank/Types.hs +93/−18
• src/Utils/Display.hs +21/−0
• src/Utils/Github.hs +93/−0
• src/Utils/Gitlab.hs +93/−0
• src/Utils/Req.hs +56/−0
• tests/Test/Krank/Checkers/IssueTrackerSpec.hs +197/−67
• tests/Test/Utils/GithubSpec.hs +66/−0
• tests/Test/Utils/GitlabSpec.hs +73/−0

@@ -1,5 +1,20 @@ # Revision history for krank +## 0.2.0 -- 2020-04-19++* GHC 8.10 support+* Output is more compact and more detailed.+* Output is now colored (can be disabled with `--no-colors`).+* Gitlab support. See `--issuetracker-gitlabhost` for host / api key pairs.+* Huge performance improvement. Parsing a huge codebase should only be a matter+  of a few seconds.+* Parallel request execution. Requests to the issue tracker host are not+  sequential anymore. This can dramatically reduce the runtime.+* Ignore line. Add `krank:ignore-line` in your comments and the associated+  closed issue won't be seen as an error anymore.+* Failure mode: `krank` will return non 0 exit code if an issue is closed (an+  not ignored).+ ## 0.1.0.0 -- 2019-10-21  * First version. Released on an unsuspecting world.

@@ -25,3 +25,7 @@ # Hacking  Edit code, ensure that test are passing and open a pull request on Github. Thank you ;)++- `nix-build -A krank` will build it+- `nix-build -A ormolu` will check formatting using ormolu. You can use `nix-shell -A ormolu-fix` to fix your code.+- `nix-build -A hlint` will lint with hlint. You can use `nix-shell -A hlint-fix` to fix your code.

@@ -1,8 +1,14 @@ # Krank +![Hackage](https://img.shields.io/hackage/v/krank)+![CircleCI](https://img.shields.io/circleci/build/github/guibou/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.+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 @@ -13,32 +19,40 @@ ```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+default.nix:20:20: info:+  still Open: https://github.com/NixOS/nix/issues/2733 -[Error] issue #22 is now Closed-    in: guibou/PyF-    file: src/Foo.hs:100:4+foo.hs:67:11: error:+  now Closed: https://github.com/bazelbuild/bazel/issues/6313 ``` +`krank` will fail (i.e. non-zero exit code) in case of any error.+ 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!+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.+You can check `krank --help` for a list of options, such as+configuring your API token for external services, such as github and+gitlab.  # 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.+- [IssueTracker](docs/Checkers/IssueTracker.md) is listing Github and+  Gitlab 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. +# Red herring++If you want to ignore all krank checkers on a given line of code, add `krank:ignore-line` on this+same line. Krank will then skip this line and not report anything on it+ # 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).+- Krank is available on+  [Hackage](http://hackage.haskell.org/package/krank), 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).

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

@@ -1,62 +1,93 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}--import System.Environment (getArgs)-import System.Exit (exitFailure)-import System.IO (hPutStrLn, stderr)+{-# LANGUAGE ViewPatterns #-} -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 qualified Data.Map as Map+import qualified Data.Text as Text import Krank-import Krank.Formatter import Krank.Types+import qualified Options.Applicative as Opt+import Options.Applicative ((<**>), many, some)+import PyF (fmt)+import System.Console.Pretty (supportsPretty)+import System.Exit (exitFailure)+import Text.Regex.PCRE.Heavy -data KrankOpts = KrankOpts {-  codeFilePaths :: [FilePath],-  krankConfig :: KrankConfig-}+data KrankOpts+  = KrankOpts+      { codeFilePaths :: [FilePath],+        krankConfig :: KrankConfig+      }  filesToParse :: Opt.Parser [FilePath]-filesToParse = many (Opt.argument Opt.str (Opt.metavar "FILES..."))+filesToParse = some (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"))+githubKeyToParse =+  optional+    ( GithubKey+        <$> Opt.strOption+          ( Opt.long "issuetracker-githubkey"+              <> Opt.metavar "PERSONAL_GITHUB_KEY"+              <> Opt.help "A github developer key to allow for more API calls or access to private github repo 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")+parseGitlabKey :: Opt.ReadM (GitlabHost, GitlabKey)+parseGitlabKey = Opt.eitherReader $ \(Text.pack -> s) -> case scan [re|^([^=]+)=(.+)$|] s of+  [(_, [x, y])] -> Right (GitlabHost x, GitlabKey y)+  _ -> Left [fmt|Unable to parse gitlab key=value from: {s}|]++gitlabKeyToParse :: Opt.Parser (Map.Map GitlabHost GitlabKey)+gitlabKeyToParse =+  Map.fromList+    <$> many+      ( Opt.option parseGitlabKey $+          Opt.long "issuetracker-gitlabhost"+            <> Opt.metavar "HOST=PERSONAL_GITLAB_KEY"+            <> Opt.help "A couple of gitlab host and developer key to allow reaching private gitlab repo for the IssueTracker checker. Can be specified multiple times."       ) -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" )+noColorParse :: Opt.Parser Bool+noColorParse =+  not+    <$> Opt.switch+      ( Opt.long "no-colors"+          <> Opt.help "Disable colored outputs"+      ) -runKrank :: FilePath -> KrankConfig -> IO ()-runKrank path options = do-  violations <- runReaderT (processFile path) options-  putStr . unpack . showViolations $ violations+optionsParser :: Opt.Parser KrankOpts+optionsParser =+  KrankOpts+    <$> filesToParse+    <*> ( KrankConfig+            <$> githubKeyToParse+            <*> gitlabKeyToParse+            <*> Opt.switch+              ( Opt.long "dry-run"+                  <> Opt.help "Perform a dry run. Parse file, but do not execute HTTP requests"+              )+            <*> noColorParse+        ) +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"+    )+ 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}|])+  canUseColor <- supportsPretty+  config <- Opt.execParser opts+  let kConfig =+        (krankConfig config)+          { useColors = useColors (krankConfig config) && canUseColor+          }+  success <- runReaderT (unKrank $ runKrank (codeFilePaths config)) kConfig+  unless success exitFailure

@@ -11,6 +11,7 @@  **IssueTracker** currently supports the following list of issue trackers: * Github+* Gitlab  ## Configuration @@ -37,3 +38,12 @@ ([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++### Gitlab++You can provide a gitlab **Personal Access+Token** using `--issuetracker-gitlabhost` in the form+`hostname=key`. For example, `--issuetracker-gitlabhost+gitlab.ghc.org=F6712`. You'll find more informations in the gitlab+documentation for [personal access+token](https://docs.gitlab.com/ee/user/profile/personal_access_tokens.html).

@@ -1,6 +1,6 @@ cabal-version:       >=1.10 name:                krank-version:             0.1.0+version:             0.2.0 synopsis: Krank checks your code source comments for important markers -- description: bug-reports: https://github.com/guibou/krank/issues@@ -17,23 +17,32 @@  library   exposed-modules:     Krank+                       Krank.Checkers.Ignore                        Krank.Checkers.IssueTracker                        Krank.Formatter                        Krank.Types+                       Utils.Display+                       Utils.Github+                       Utils.Gitlab+                       Utils.Req -  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+  build-depends:       base >= 4.9+                       , PyF >= 0.8.1.0+                       , aeson >= 1.4.4+                       , bytestring+                       , containers+                       , http-client >= 0.6+                       , http-types >= 0.12+                       , lifted-async                        , mtl+                       , pcre-heavy+                       , pretty-terminal+                       , req >= 2.1.0                        , safe-exceptions+                       , text >= 1.2.3+                       , unordered-containers >= 0.2.10   hs-source-dirs:      src-  ghc-options: -Wall+  ghc-options:         -Wall   default-language:    Haskell2010  test-suite krank-test@@ -41,23 +50,40 @@   hs-source-dirs:      tests   main-is:             Spec.hs   other-modules:       Test.Krank.Checkers.IssueTrackerSpec+                       Test.Utils.GithubSpec+                       Test.Utils.GitlabSpec   build-tools:-  build-depends:       base-                       , hspec >= 2.7 && < 2.8-                       , PyF >= 0.8.1.0 && < 0.9+  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-                       , megaparsec+                       , 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  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+  build-depends:       base >=4.9 && <= 5.0                        , PyF-                       , safe-exceptions+                       , containers+                       , krank                        , mtl+                       , optparse-applicative >= 0.14+                       , pcre-heavy+                       , pretty-terminal+                       , text   hs-source-dirs:      app   default-language:    Haskell2010+  ghc-options:         -Wall -threaded -rtsopts

@@ -1,13 +1,94 @@-module Krank (-  processFile-  ) where+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} +module Krank+  ( runKrank,+    Krank (..),+  )+where++import Control.Concurrent.Async.Lifted (mapConcurrently)+import Control.Exception.Safe+import Control.Monad.Reader+import qualified Data.ByteString+import Data.Coerce+import qualified Data.Text as Text+import qualified Data.Text.IO as Text.IO+import Krank.Checkers.Ignore (filterViolations) import qualified Krank.Checkers.IssueTracker as IT+import Krank.Formatter import Krank.Types-import Control.Monad.Reader+import qualified Network.HTTP.Req as Req+import PyF+import System.IO (stderr) -processFile :: FilePath      -- ^ the file to analyze-            -> ReaderT KrankConfig IO [Violation]+processFile ::+  MonadKrank m =>+  -- | the file to analyze+  FilePath ->+  m [Violation] processFile filePath = do-  content <- liftIO $ readFile filePath-  IT.checkText filePath content+  content <- krankReadFile filePath+  violations <- IT.checkText filePath content+  let filtered = filterViolations violations filePath content+  -- forcing 'violations' to WHNF forces more of the processing to happen inside the thread and+  -- improves a bit the runtime performances in parallel.+  -- forcing to Normal Form (with deepseq) does not bring anymore improvement+  pure $! filtered++runKrank :: MonadKrank m => [FilePath] -> m Bool+runKrank paths = do+  KrankConfig {useColors} <- krankAsks id+  res <- krankForConcurrently paths $ \path ->+    (Right <$> processFile path)+      `catchAny` (\(SomeException e) -> pure $ Left [fmt|Error when processing {path}: {show e}|])+  forM_ res $ \case+    Left err -> krankPutStrLnStderr err+    Right violations -> krankPutStr (foldMap (showViolation useColors) violations)+  -- Check if any violation is an error+  pure $ not (any isError res)++-- | Returns 'True' if any violation level is error or if any error occurs.+isError :: Either Text.Text [Violation] -> Bool+isError (Left _) = True+isError (Right violations) = any isViolationError violations++isViolationError :: Violation -> Bool+isViolationError Violation {level = Error} = True+isViolationError _ = False++-- | This just exists to avoid the orphan instance on MonadKrank+newtype Krank t = Krank {unKrank :: ReaderT KrankConfig IO t}+  deriving newtype (Functor, Applicative, Monad, MonadCatch, MonadThrow)++-- | The real monad implementation for Krank+instance MonadKrank Krank where+  krankReadFile = Krank . liftIO . Data.ByteString.readFile++  krankAsks = Krank . asks++  krankPutStrLnStderr = Krank . liftIO . Text.IO.hPutStrLn stderr++  krankPutStr = Krank . liftIO . Text.IO.putStr++  -- Use threads for concurrency+  krankMapConcurrently f l = Krank $ mapConcurrently (coerce . f) l++  -- This implements a Req REST request+  krankRunRESTRequest url headers = Krank+    $ Req.runReq Req.defaultHttpConfig+    $ do+      r <-+        Req.req+          Req.GET+          url+          Req.NoReqBody+          Req.jsonResponse+          ( Req.header "User-Agent" "krank"+              <> headers+          )+      pure $ Req.responseBody r

@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Krank.Checkers.Ignore+  ( IgnoreCommand (..),+    filterViolations,+  )+where++import qualified Data.ByteString.Char8 as ByteString+import Data.ByteString.Char8 (ByteString)+import Data.HashMap.Strict as HashM+import qualified Data.List as DataL+import Krank.Types+import PyF (fmt)+import qualified Text.Regex.PCRE.Heavy as RE++data IgnoreCommand = IgnoreLine deriving (Show, Eq)++-- | This regex represents a krank ignore marker+ignoreRe :: RE.Regex+ignoreRe = [RE.re|krank:ignore-(line)|]++-- TODO: support more "ignore" (checker specific, all file, next line)++-- | Extract all issues on one line and returns a list of ignore keyword+extractIssuesOnALine :: ByteString -> [(Int, IgnoreCommand)]+extractIssuesOnALine lineContent = Prelude.map f (RE.scan ignoreRe lineContent)+  where+    f (match, [command]) = (colNo, ignoreCommand)+      where+        colNo = 1 + ByteString.length (fst $ ByteString.breakSubstring match lineContent)+        ignoreCommand+          | command == "line" = IgnoreLine+          | otherwise = error [fmt|Impossible case, update the guard with: {ByteString.unpack command}|]+    -- This case seems impossible, the reasons for pattern match issues are:+    --  A number of items different than 1 in the list: there is only 1 matching groups in the regex+    f res = error ("Error: impossible match" <> show res)++-- | Extract all ignore markers correctly localized+-- Note: we use 'ByteString' internally. This way we do not have to+-- care about the possible encoding of the input files.+-- In programming world, we mostly use ascii variants. This gives a+-- few performance improvement compared to initially converting+-- everything to 'Text' and search on it.+extractIgnores ::+  -- | Path of the file+  FilePath ->+  -- | Content of the file+  ByteString ->+  [Localized IgnoreCommand]+extractIgnores filePath toCheck = concat (zipWith extract [1 ..] (ByteString.lines toCheck))+  where+    extract lineNo lineContent = Prelude.map f (extractIssuesOnALine lineContent)+      where+        f (colNo, gitIssue) = Localized (SourcePos filePath lineNo colNo) gitIssue++-- | Takes a list of Violation, some ignore commands and remove all those that are ignored due to an+-- ignore marker+filterViolations ::+  -- | List of Violation to filter+  [Violation] ->+  -- | Path of the file+  FilePath ->+  -- | Content of the file+  ByteString ->+  [Violation]+filterViolations violations filePath content =+  DataL.filter isNotIgnored violations+  where+    ignoreCommands = extractIgnores filePath content+    f hashMap ignoreCommand = HashM.insert (lineNumber . getLocation $ ignoreCommand) (unLocalized ignoreCommand) hashMap+    ignoreIndex = foldl f HashM.empty ignoreCommands+    isIgnored violation = HashM.lookup (lineNumber . location $ violation) ignoreIndex == Just IgnoreLine+    isNotIgnored = not . isIgnored

@@ -1,212 +1,253 @@-{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ViewPatterns #-} -module Krank.Checkers.IssueTracker (-  GitIssue(..)-  , GitServer(..)-  , Localized(..)-  , checkText-  , extractIssues-  , githubRE-  -- , gitlabRE-  , gitRepoRE-  ) where+module Krank.Checkers.IssueTracker+  ( GitIssue (..),+    GitServer (..),+    Localized (..),+    checkText,+    extractIssues,+    gitRepoRe,+    serverDomain,+    extractIssuesOnALine,+  )+where -import Control.Applicative ((*>), optional) import Control.Exception.Safe (catch)-import Data.Aeson (Value, (.:))+import Data.Aeson ((.:), Value) import qualified Data.Aeson.Types as AesonT-import qualified Data.ByteString.UTF8 as BSU-import Data.Char (isDigit)+import qualified Data.ByteString.Char8 as ByteString+import Data.ByteString.Char8 (ByteString)+import qualified Data.Map as Map import Data.Text (Text, pack)+import qualified Data.Text.Encoding as Text.Encoding+import Krank.Types 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+import qualified Text.Regex.PCRE.Heavy as RE+import Utils.Github (showGithubException)+import Utils.Gitlab (showGitlabException) -data GitServer = Github-  -- Gitlab -- TODO: enable gitlab again+data GitServer = Github | Gitlab GitlabHost   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 GitIssue+  = GitIssue+      { server :: GitServer,+        owner :: Text,+        repo :: Text,+        issueNum :: Int+      }+  deriving (Eq, Show) -data GitIssueWithStatus = GitIssueWithStatus {-  gitIssue :: Localized GitIssue,-  issueStatus :: IssueStatus-} deriving (Eq, Show)+data GitIssueWithStatus+  = GitIssueWithStatus+      { gitIssue :: Localized GitIssue,+        issueStatus :: IssueStatus+      }+  deriving (Eq, Show) -serverDomain :: GitServer-             -> String+serverDomain ::+  GitServer ->+  Text serverDomain Github = "github.com"--- serverDomain Gitlab = "gitlab.com"--type Parser t = Parsec Void String t--githubRE :: Parser GitIssue-githubRE = gitRepoRE Github+serverDomain (Gitlab (GitlabHost h)) = h --- gitlabRE :: Parser GitIssue--- gitlabRE = gitRepoRE Gitlab+-- | This regex represents a github/gitlab issue URL+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 :: 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)+-- | Extract all issues on one line and returns a list of the raw text associated with an issue+extractIssuesOnALine :: ByteString -> [(Int, GitIssue)]+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)+      where+        colNo = 1 + ByteString.length (fst $ ByteString.breakSubstring match lineContent)+        provider+          | domain == "github.com" = Github+          -- TODO: We suppose that all other cases are gitlab+          -- The only thing we risk here is a query with the wrong+          -- API to an irrelevant host.+          | otherwise = Gitlab (GitlabHost $ Text.Encoding.decodeUtf8 domain)+    -- This case seems impossible, the reasons for pattern match issues are:+    --  A number of items different than 4 in the list: there is only 4 matching groups in the regex+    --  An invalid `decimal` conversion. That's impossible either+    --  because the pattern for the issue number is `[0-9]+`+    f res = error ("Error: impossible match" <> show res) -extractIssues-  :: FilePath-  -> String-  -> [Localized GitIssue]-extractIssues filePath toCheck = case parse (findAllCap patterns) filePath toCheck of-  Left _ -> []-  Right res -> map snd $ rights res+-- | Extract all issues correctly localized+-- Note: we use 'ByteString' internally. This way we do not have to+-- care about the possible encoding of the input files.+-- In programming world, we mostly use ascii variants. This gives a+-- few performance improvement compared to initially converting+-- everything to 'Text' and search on it.+extractIssues ::+  -- | Path of the file+  FilePath ->+  -- | Content of the file+  ByteString ->+  [Localized GitIssue]+extractIssues filePath toCheck = concat (zipWith extract [1 ..] (ByteString.lines toCheck))   where-    patterns = localized $ choice [-      githubRE-      -- gitlabRE -- TODO: enable gitlab again-      ]+    extract lineNo lineContent = map f (extractIssuesOnALine lineContent)+      where+        f (colNo, gitIssue) = Localized (SourcePos filePath lineNo colNo) gitIssue  -- Supports only github for the moment-issueUrl :: GitIssue-         -> Req.Url 'Req.Https+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"+  Github -> Req.https "api.github.com" Req./: "repos" Req./: owner issue Req./: repo issue Req./: "issues" Req./~ issueNum issue+  Gitlab (GitlabHost host) -> Req.https host Req./: "api" Req./: "v4" Req./: "projects" Req./: [fmt|{owner issue}/{repo issue}|] Req./: "issues" Req./~ issueNum issue  -- 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+tryRestIssue ::+  MonadKrank m =>+  Localized GitIssue ->+  m Value+tryRestIssue locIssue = do+  let issue = unLocalized locIssue+  let url = issueUrl issue+  headers <- headersFor issue+  krankRunRESTRequest url headers -  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+headersFor ::+  MonadKrank m =>+  GitIssue ->+  m (Req.Option 'Req.Https)+headersFor issue = do+  mGithubKey <- krankAsks githubKey+  mGitlabKeys <- krankAsks gitlabKeys+  case server issue of+    Github -> case mGithubKey of+      Just (GithubKey token) -> pure $ Req.oAuth2Token (Text.Encoding.encodeUtf8 token)+      Nothing -> pure mempty+    Gitlab host -> case Map.lookup host mGitlabKeys of+      Just (GitlabKey token) -> pure $ Req.header "PRIVATE-TOKEN" (Text.Encoding.encodeUtf8 token)+      Nothing -> pure mempty +httpExcHandler ::+  MonadKrank m =>+  GitServer ->+  Req.HttpException ->+  m Value+httpExcHandler gitServer exc =+  pure . AesonT.object $ [("error", AesonT.String . pack $ [fmt|{(showGitServerException gitServer exc)}|])] -httpExcHandler :: Req.Url 'Req.Https-               -> Req.HttpException-               -> ReaderT KrankConfig IO Value-httpExcHandler url _ = pure . AesonT.object $ [("error", AesonT.String . pack . show $ url)]+showGitServerException ::+  GitServer ->+  Req.HttpException ->+  Text+showGitServerException Github exc = showGithubException exc+showGitServerException (Gitlab _) exc = showGitlabException exc -restIssue :: Req.Url 'Req.Https-          -> ReaderT KrankConfig IO Value-restIssue url = catch (tryRestIssue url) (httpExcHandler url)+restIssue ::+  MonadKrank m =>+  Localized GitIssue ->+  m Value+restIssue issue = catch (tryRestIssue issue) (httpExcHandler . server . unLocalized $ issue) -statusParser :: Value-            -> Either Text IssueStatus+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+  where+    readState (AesonT.Success status) = case status of+      "closed" -> Right Closed -- Both Gitlab and Github use the same keyword for closed+      "open" -> Right Open -- Github uses the 'open' status+      "opened" -> Right Open -- Gitlab uses the 'opened' status+      _ -> Left [fmt|Could not parse status '{status}'|]+    readState (AesonT.Error _) = Left $ errorParser o statusParser _ = Left "invalid JSON" -errorParser :: AesonT.Object-            -> Text+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"+  where+    readErr (AesonT.Success errText) = pack errText+    readErr (AesonT.Error _) = "invalid JSON" -gitIssuesWithStatus :: [Localized GitIssue]-                    -> ReaderT KrankConfig IO [Either (Text, Localized GitIssue) GitIssueWithStatus]+gitIssuesWithStatus ::+  MonadKrank m =>+  [Localized GitIssue] ->+  m [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"+  statuses <- krankMapConcurrently restIssue issues+  pure $ zipWith f issues (fmap statusParser statuses)+  where+    f issue (Left err) = Left (err, issue)+    f issue (Right is) = Right $ GitIssueWithStatus issue is -issueToLevel :: GitIssueWithStatus-             -> ViolationLevel+issueToLevel ::+  GitIssueWithStatus ->+  ViolationLevel issueToLevel i = case issueStatus i of-  Open   -> Info+  Open -> Info   Closed -> Error -issueToSnippet :: GitIssueWithStatus-               -> Text-issueToSnippet i = [fmt|{owner issue}/{repo issue}|]-  where-    issue = unLocalized $ gitIssue i--issueToMessage :: GitIssueWithStatus-               -> Text+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+  Open -> [fmt|still Open|]+  Closed -> [fmt|now Closed - You can remove the workaround you used there|] -checkText :: FilePath-          -> String-          -> ReaderT KrankConfig IO [Violation]+issuePrintUrl :: GitIssue -> Text+issuePrintUrl GitIssue {owner, repo, server, issueNum} = [fmt|IssueTracker check for https://{serverDomain server}/{owner}/{repo}/issues/{issueNum}|]++checkText ::+  MonadKrank m =>+  FilePath ->+  ByteString ->+  m [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))+  isDryRun <- krankAsks dryRun+  if isDryRun+    then+      pure $+        fmap+          ( \issue ->+              Violation+                { checker = issuePrintUrl . unLocalized $ issue,+                  level = Info,+                  message = "Dry run",+                  location = getLocation (issue :: Localized GitIssue)+                }+          )+          issues+    else do+      issuesWithStatus <- gitIssuesWithStatus issues+      pure $ fmap f issuesWithStatus+  where+    f (Left (err, issue)) =+      Violation+        { checker = issuePrintUrl . unLocalized $ issue,+          level = Warning,+          message = "Error when calling the API:\n" <> err,+          location = getLocation (issue :: Localized GitIssue)+        }+    f (Right issue) =+      Violation+        { checker = issuePrintUrl (unLocalized . gitIssue $ issue),+          level = issueToLevel issue,+          message = issueToMessage issue,+          location = getLocation (gitIssue issue :: Localized GitIssue)+        }

@@ -1,24 +1,39 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -module Krank.Formatter (-  showViolations-  ) where+module Krank.Formatter+  ( showViolation,+  )+where  import Data.Text (Text)+import Krank.Types import PyF (fmt)-import Text.Megaparsec.Pos (sourcePosPretty)+import System.Console.Pretty+import Utils.Display (indent) -import Krank.Types+showViolation ::+  Bool ->+  Violation ->+  Text+showViolation useColors Violation {checker, location, level, message} =+  [fmt|+{showSourcePos location}: {showViolationLevel useColors level}:+{indent 2 checker}+{indent 4 message}+|] -showViolations :: [Violation]-               -> Text-showViolations = foldMap showViolation+showViolationLevel :: Bool -> ViolationLevel -> String+showViolationLevel enableColor = \case+  Info -> colorized Green "info"+  Warning -> colorized Magenta "warning"+  Error -> colorized Red "error"+  where+    colorized c+      | enableColor = style Bold . color c+      | otherwise = id -showViolation :: Violation-              -> Text-showViolation violation = [fmt|-[{(show (level violation))}] {message violation}-    in: {snippet violation}-    file: {sourcePosPretty (location violation)}-|]+showSourcePos :: SourcePos -> String+showSourcePos (SourcePos path line column) = [fmt|{path}:{line}:{column}|]

@@ -1,25 +1,100 @@-module Krank.Types (-  GithubKey(..)-  , Violation(..)-  , ViolationLevel(..)-  , KrankConfig(..)-  ) where+{-# LANGUAGE DataKinds #-} +module Krank.Types+  ( GithubKey (..),+    GitlabHost (..),+    GitlabKey (..),+    Violation (..),+    ViolationLevel (..),+    KrankConfig (..),+    SourcePos (..),+    Localized (..),+    MonadKrank (..),+  )+where++import Control.Exception.Safe (MonadCatch)+import Data.Aeson (FromJSON)+import Data.ByteString+import Data.Map (Map) import Data.Text (Text)-import Text.Megaparsec (SourcePos)+import qualified Network.HTTP.Req as Req -newtype GithubKey = GithubKey String+newtype GithubKey = GithubKey Text deriving (Show) +newtype GitlabKey = GitlabKey Text deriving (Show)++newtype GitlabHost = GitlabHost Text deriving (Show, Ord, Eq)+ data ViolationLevel = Info | Warning | Error deriving (Show) -data Violation = Violation { checker :: Text-                           , level :: ViolationLevel-                           , snippet :: Text-                           , message :: Text-                           , location :: SourcePos-                           } deriving (Show)+data SourcePos+  = SourcePos+      { file :: FilePath,+        lineNumber :: Int,+        colNumber :: Int+      }+  deriving (Show, Eq, Ord) -data KrankConfig = KrankConfig-  { githubKey :: Maybe GithubKey-  , dryRun :: Bool-  }+-- | Represents a localized chunk of information+-- in a file+data Localized t+  = Localized+      { getLocation :: SourcePos,+        unLocalized :: t+      }+  deriving (Show, Eq)++data Violation+  = Violation+      { -- | A textual representation of the checker. Most of the time that's+        -- the chunck of text parsed+        checker :: Text,+        -- | The 'ViolationLevel' associated with the result+        level :: ViolationLevel,+        -- | A message describing the error+        message :: Text,+        -- | The position in the input sources of the chunck+        location :: SourcePos+      }+  deriving (Show)++data KrankConfig+  = KrankConfig+      { -- | The github oAuth token+        githubKey :: Maybe GithubKey,+        -- | The gitlab oAuth token+        gitlabKeys :: Map GitlabHost GitlabKey,+        -- | If 'True', all IO operations, such as HTTP requests, are ignored+        dryRun :: Bool,+        -- | Use color for formatting+        useColors :: Bool+      }+  deriving (Show)++-- | This monad represents all the effect that Krank needs+class (Monad m, MonadCatch m) => MonadKrank m where+  -- | Run a REST requet+  krankRunRESTRequest :: FromJSON t => Req.Url 'Req.Https -> Req.Option 'Req.Https -> m t++  -- | Read the configuration+  krankAsks :: (KrankConfig -> b) -> m b++  -- * Concurrency++  -- | Apply a function on many item in a concurrent way+  krankMapConcurrently :: (a -> m b) -> [a] -> m [b]++  krankForConcurrently :: [a] -> (a -> m b) -> m [b]+  krankForConcurrently = flip krankMapConcurrently++  -- * IO Part++  -- | Read a file from filesystem+  krankReadFile :: FilePath -> m ByteString++  -- | Log an error (with trailing \n)+  krankPutStrLnStderr :: Text -> m ()++  -- | Log a message (without trailing \n)+  krankPutStr :: Text -> m ()

@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Utils.Display+  ( indent,+  )+where++import qualified Data.Text as Text+import PyF (fmt)++-- | indent the text given by a certain number of space character+-- If the text given contains multiple lines, all the lines but the first will be prefixed by the+-- continuation character '|'+indent :: Int -> Text.Text -> Text.Text+indent nbSpaces text = indentedText+  where+    (firstLine : nextLines) = Text.splitOn "\n" text+    prefixedLines = map (\a -> [fmt|| {a}|]) nextLines+    indentedLines = map (\a -> [fmt|{replicate nbSpaces ' '}{a}|]) (firstLine : prefixedLines)+    indentedText = Text.intercalate "\n" indentedLines

@@ -0,0 +1,93 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Utils.Github+  ( showGithubException,+    githubAPILimitErrorText,+    githubNotFoundErrorText,+  )+where++import Data.Aeson (FromJSON, ToJSON, decode)+import Data.ByteString.Char8 (ByteString)+import Data.ByteString.Lazy (fromStrict)+import Data.Text (Text, isPrefixOf)+import GHC.Generics (Generic)+import qualified Network.HTTP.Client as Client+import qualified Network.HTTP.Req as Req+import Network.HTTP.Types (Status (..))+import PyF (fmt)+import Utils.Req (showHTTPException, showRawResponse)++-- | Represents a typical Github Error serialized as JSON like so:+--+-- @+-- {+--    "message": "the error reason"+-- }+-- @+newtype GithubError+  = GithubError+      { message :: Text+      }+  deriving stock (Generic, Show)+  deriving anyclass (FromJSON, ToJSON)++-- | Uses the helper to show generic HTTP issues and provides a specific handler for Github+-- "business" exceptions+showGithubException ::+  Req.HttpException ->+  Text+showGithubException = showHTTPException handleGithubException++handleGithubException ::+  Client.Response () ->+  ByteString ->+  Text+handleGithubException resp body =+  case statusCode (Client.responseStatus resp) of+    400 -> tryShowNiceErr+    404 -> githubNotFoundErrorText+    403 -> tryShowNiceErr+    _ -> showRawResponse resp body+  where+    err = decode $ fromStrict body :: Maybe GithubError+    tryShowNiceErr = case err of+      Just githubError -> showRawGithubMessage githubError+      Nothing -> showRawResponse resp body++showRawGithubMessage ::+  GithubError ->+  Text+showRawGithubMessage err+  | isApiRateLimitError msg = githubAPILimitErrorText+  | otherwise = [fmt|From Github: {msg}|]+  where+    msg = message err++githubNotFoundErrorText :: Text+githubNotFoundErrorText =+  [fmt|\+Could not find the indicated url.+It's possible that you have mistyped the URL+If not, this URL likely points to a private repository and you need to be authenticated to query its issues.+You might want to provide a github API key with the --issuetracker-githubkey option.+See https://github.com/guibou/krank/blob/master/docs/Checkers/IssueTracker.md#private-repositories|]++githubAPILimitErrorText :: Text+githubAPILimitErrorText =+  [fmt|\+Github API Rate limit exceeded.+You might want to provide a github API key with the --issuetracker-githubkey option.+See https://github.com/guibou/krank/blob/master/docs/Checkers/IssueTracker.md#api-rate-limitation|]++apiRateLimitPrefix :: Text+apiRateLimitPrefix = "API rate limit exceeded"++isApiRateLimitError ::+  Text ->+  Bool+isApiRateLimitError = isPrefixOf apiRateLimitPrefix

@@ -0,0 +1,93 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Utils.Gitlab+  ( showGitlabException,+    gitlabAPILimitErrorText,+    gitlabNotFoundErrorText,+  )+where++import Data.Aeson (FromJSON, ToJSON, decode)+import Data.ByteString.Char8 (ByteString)+import Data.ByteString.Lazy (fromStrict)+import Data.Text (Text, isPrefixOf)+import GHC.Generics (Generic)+import qualified Network.HTTP.Client as Client+import qualified Network.HTTP.Req as Req+import Network.HTTP.Types (Status (..))+import PyF (fmt)+import Utils.Req (showHTTPException, showRawResponse)++-- | Represents a typical Gitlab Error serialized as JSON like so:+--+-- @+-- {+--    "message": "the error reason"+-- }+-- @+newtype GitlabError+  = GitlabError+      { message :: Text+      }+  deriving stock (Generic, Show)+  deriving anyclass (FromJSON, ToJSON)++-- | Uses the helper to show generic HTTP issues and provides a specific handler for Gitlab+-- "business" exceptions+showGitlabException ::+  Req.HttpException ->+  Text+showGitlabException = showHTTPException handleGitlabException++handleGitlabException ::+  Client.Response () ->+  ByteString ->+  Text+handleGitlabException resp body =+  case statusCode (Client.responseStatus resp) of+    400 -> tryShowNiceErr+    404 -> gitlabNotFoundErrorText+    403 -> tryShowNiceErr+    _ -> showRawResponse resp body+  where+    err = decode $ fromStrict body :: Maybe GitlabError+    tryShowNiceErr = case err of+      Just gitlabError -> showRawGitlabMessage gitlabError+      Nothing -> showRawResponse resp body++showRawGitlabMessage ::+  GitlabError ->+  Text+showRawGitlabMessage err+  | isApiRateLimitError msg = gitlabAPILimitErrorText+  | otherwise = [fmt|From Gitlab: {msg}|]+  where+    msg = message err++gitlabNotFoundErrorText :: Text+gitlabNotFoundErrorText =+  [fmt|\+Could not find the indicated url.+It's possible that you have mistyped the URL+If not, this URL likely points to a private repository and you need to be authenticated to query its issues.+You might want to provide a gitlab API key with the --issuetracker-gitlabhost option.+See https://github.com/guibou/krank/blob/master/docs/Checkers/IssueTracker.md#gitlab|]++gitlabAPILimitErrorText :: Text+gitlabAPILimitErrorText =+  [fmt|\+Gitlab API Rate limit exceeded.+You might want to provide a gitlab API key with the --issuetracker-gitlabhost option.+See https://github.com/guibou/krank/blob/master/docs/Checkers/IssueTracker.md#gitlab|]++apiRateLimitPrefix :: Text+apiRateLimitPrefix = "API rate limit exceeded"++isApiRateLimitError ::+  Text ->+  Bool+isApiRateLimitError = isPrefixOf apiRateLimitPrefix

@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++-- |+-- Module      : Utils.Req+-- Description : Utilities to handle Network.Req HTTP exceptions+module Utils.Req+  ( showHTTPException,+    showRawResponse,+  )+where++import Data.ByteString.Char8 (ByteString)+import Data.Text (Text, pack)+import qualified Network.HTTP.Client as Client+import qualified Network.HTTP.Req as Req+import Network.HTTP.Types (Status (..))+import PyF (fmt)++showHTTPException ::+  -- | A function that accepts a StatusCodeException details and returns the appropriate text+  (Client.Response () -> ByteString -> Text) ->+  Req.HttpException ->+  Text+showHTTPException businessExcHandler (Req.VanillaHttpException clientHttpException) = showClientHttpException businessExcHandler clientHttpException+showHTTPException _ (Req.JsonHttpException exc) = pack exc++showClientHttpException ::+  -- | A function that accepts a StatusCodeException details and returns the appropriate text+  (Client.Response () -> ByteString -> Text) ->+  Client.HttpException ->+  Text+showClientHttpException businessExcHandler (Client.HttpExceptionRequest _ excContent) = showExceptionContent businessExcHandler excContent+showClientHttpException _ (Client.InvalidUrlException _ reason) = pack reason++showExceptionContent ::+  -- | A function that accepts a StatusCodeException details and returns the appropriate text+  (Client.Response () -> ByteString -> Text) ->+  Client.HttpExceptionContent ->+  Text+showExceptionContent businessExcHandler (Client.StatusCodeException resp body) = businessExcHandler resp body+-- Catch all doing a simple and ugly show+showExceptionContent _ exc = pack . show $ exc++showRawResponse ::+  Client.Response () ->+  ByteString ->+  Text+showRawResponse resp body =+  [fmt|\+HTTP call failed: {show status} - {show statusMsg}+      {show body}\+|]+  where+    status = statusCode . Client.responseStatus $ resp+    statusMsg = statusMessage . Client.responseStatus $ resp

@@ -1,88 +1,218 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -module Test.Krank.Checkers.IssueTrackerSpec (-  spec-  ) where+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 -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)+data TestEnv+  = TestEnv+      { envFiles :: Map FilePath Data.ByteString.ByteString,+        envRestAnswers :: Map (Req.Url 'Req.Https) (Either Req.HttpException Value)+      } -      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)+newtype TestKrank t+  = TestKrank+      { unTestKrank :: WriterT ([Text], [Text]) (ReaderT (TestEnv, KrankConfig) (Either SomeException)) t+      }+  deriving newtype (Monad, Applicative, Functor, MonadThrow, MonadCatch) -      it "fails if the issue number is not an int" $ do-        let match = "github.com/guibou/krank/issues/foo" =~ githubRE-        match `shouldBe` Nothing+-- | "pure" instance of 'MonadKrank'+-- It works on a 'TestEnv'.+instance MonadKrank TestKrank where+  krankPutStrLnStderr t = TestKrank $ tell ([], [t]) -      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+  krankPutStr t = TestKrank $ tell ([t], []) -      it "fails if github not in path" $ do-        let match = "google.com/guibou/krank/issues/1" =~ githubRE-        match `shouldBe` Nothing+  krankAsks f = TestKrank $ asks (f . snd) -      it "fails if not a github issue" $ do-        let match = "github.com/guibou/krank/branches/1" =~ githubRE-        match `shouldBe` Nothing+  krankMapConcurrently f l = TestKrank $ mapM (coerce . f) l -      it "fails on partial match" $ do-        let match = "github.com/guibou/krank/" =~ githubRE-        match `shouldBe` Nothing+  krankReadFile path = TestKrank $ do+    files <- asks (envFiles . fst)+    case Map.lookup path files of+      Nothing -> throw (userError "file not found")+      Just c -> pure c -      it "fails on partial match (just missing the issue number)" $ do-        let match = "github.com/guibou/krank/issues/" =~ githubRE-        match `shouldBe` Nothing+  -- 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 -    -- 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)+check :: ByteString -> Maybe GitIssue+check a = case extractIssuesOnALine a of+  [(_, x)] -> Just x+  _ -> Nothing -    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)+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) -    describe "#extractIssues" $-      it "handles both github and gitlab" $ do-        let match = extractIssues "localFile" [fmt|https://github.com/guibou/krank/issues/2+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" (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 ]+        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]+                     )+                   )

@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Utils.GithubSpec+  ( spec,+  )+where++import Data.Aeson (Value (..), encode)+import Data.ByteString.Lazy (ByteString, toStrict)+import Data.HashMap.Strict (singleton)+import Data.Text (Text, isInfixOf, isPrefixOf)+import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), createCookieJar, defaultRequest)+import Network.HTTP.Client.Internal (Response (..), ResponseClose (..))+import Network.HTTP.Req (HttpException (..))+import Network.HTTP.Types (Status, status400, status403, status404)+import Network.HTTP.Types.Version (http11)+import Test.Hspec+import Utils.Github (githubAPILimitErrorText, githubNotFoundErrorText, showGithubException)+import Utils.Req (showHTTPException, showRawResponse)++spec :: Spec+spec = do+  describe "Utils.Github" $ do+    context "Github \"business\" errors, 4xx status code, \"message\" structure" $ do+      it "Display the content of the error message, deserialized from the JSON" $ do+        let errorMsg = "some_error"+        let body = mkGithubErrorBody errorMsg+        let errorText = getErrorText body status400+        errorText `shouldSatisfy` isPrefixOf "From Github:"+        errorText `shouldSatisfy` isInfixOf errorMsg+    context "Github API Rate Limit error" $ do+      it "Displays the specific message for API errors" $ do+        let errorMsg = "API rate limit exceeded for 86.111.137.132. (But here's the good news: Authenticated requests get a higher rate limit. Check out the documentation for more details.)"+        let body = mkGithubErrorBody errorMsg+        let errorText = getErrorText body status403+        errorText `shouldSatisfy` isInfixOf githubAPILimitErrorText+    context "Github Private repo error" $ do+      it "Displays the specific message for private repo error errors" $ do+        let errorMsg = "Not Found"+        let body = mkGithubErrorBody errorMsg+        let errorText = getErrorText body status404+        errorText `shouldSatisfy` isInfixOf githubNotFoundErrorText+    context "Non-JSON response exception" $ do+      it "Shows the raw exception, through the generic helper" $ do+        let exception = JsonHttpException "JSON decoding failed"+        showGithubException exception `shouldBe` showHTTPException showRawResponse exception+    context "Invalid URL exception" $ do+      it "Shows the raw exception, through the generic helper" $ do+        let exception = VanillaHttpException $ InvalidUrlException "file://foo" "bar"+        showGithubException exception `shouldBe` showHTTPException showRawResponse exception+    context "otherHttpException" $ do+      it "Shows the raw exception, through the generic helper" $ do+        let exception = VanillaHttpException $ HttpExceptionRequest defaultRequest ConnectionTimeout+        showGithubException exception `shouldBe` showHTTPException showRawResponse exception++dummyResponse :: Status -> Response ()+dummyResponse status = Response status http11 [] () (createCookieJar []) (ResponseClose $ pure ())++-- | From a raw error message to a JSON formatted github error+mkGithubErrorBody :: Text -> ByteString+mkGithubErrorBody msg = encode $ Object $ singleton "message" (String msg)++-- | From a raw JSON response body and status code to the interpreted displayed text+getErrorText :: ByteString -> Status -> Text+getErrorText body status = showGithubException $ VanillaHttpException $ HttpExceptionRequest defaultRequest (StatusCodeException (dummyResponse status) (toStrict body))

@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- Leaving unnecessary do because+--  * they improve readability+--  * if you add a context, or an it, it'll still compile, without remembering that there was no do+--  before because at the time there was a single function inside+--  * without those do, ormolu does some formatting that looks crazy to me+{- Hlint ignore "Redundant do" -}++module Test.Utils.GitlabSpec+  ( spec,+  )+where++import Data.Aeson (Value (..), encode)+import Data.ByteString.Lazy (ByteString, toStrict)+import Data.HashMap.Strict (singleton)+import Data.Text (Text, isInfixOf, isPrefixOf)+import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), createCookieJar, defaultRequest)+import Network.HTTP.Client.Internal (Response (..), ResponseClose (..))+import Network.HTTP.Req (HttpException (..))+import Network.HTTP.Types (Status, status400, status403, status404)+import Network.HTTP.Types.Version (http11)+import Test.Hspec+import Utils.Gitlab (gitlabAPILimitErrorText, gitlabNotFoundErrorText, showGitlabException)+import Utils.Req (showHTTPException, showRawResponse)++spec :: Spec+spec = do+  describe "Utils.Gitlab" $ do+    context "Gitlab \"business\" errors, 4xx status code, \"message\" structure" $ do+      it "Display the content of the error message, deserialized from the JSON" $ do+        let errorMsg = "some_error"+        let body = mkGitlabErrorBody errorMsg+        let errorText = getErrorText body status400+        errorText `shouldSatisfy` isPrefixOf "From Gitlab:"+        errorText `shouldSatisfy` isInfixOf errorMsg+    context "Gitlab API Rate Limit error" $ do+      it "Displays the specific message for API errors" $ do+        let errorMsg = "API rate limit exceeded for 86.111.137.132. (But here's the good news: Authenticated requests get a higher rate limit. Check out the documentation for more details.)"+        let body = mkGitlabErrorBody errorMsg+        let errorText = getErrorText body status403+        errorText `shouldSatisfy` isInfixOf gitlabAPILimitErrorText+    context "Gitlab Private repo error" $ do+      it "Displays the specific message for private repo error errors" $ do+        let errorMsg = "Not Found"+        let body = mkGitlabErrorBody errorMsg+        let errorText = getErrorText body status404+        errorText `shouldSatisfy` isInfixOf gitlabNotFoundErrorText+    context "Non-JSON response exception" $ do+      it "Shows the raw exception, through the generic helper" $ do+        let exception = JsonHttpException "JSON decoding failed"+        showGitlabException exception `shouldBe` showHTTPException showRawResponse exception+    context "Invalid URL exception" $ do+      it "Shows the raw exception, through the generic helper" $ do+        let exception = VanillaHttpException $ InvalidUrlException "file://foo" "bar"+        showGitlabException exception `shouldBe` showHTTPException showRawResponse exception+    context "otherHttpException" $ do+      it "Shows the raw exception, through the generic helper" $ do+        let exception = VanillaHttpException $ HttpExceptionRequest defaultRequest ConnectionTimeout+        showGitlabException exception `shouldBe` showHTTPException showRawResponse exception++dummyResponse :: Status -> Response ()+dummyResponse status = Response status http11 [] () (createCookieJar []) (ResponseClose $ pure ())++-- | From a raw error message to a JSON formatted gitlab error+mkGitlabErrorBody :: Text -> ByteString+mkGitlabErrorBody msg = encode $ Object $ singleton "message" (String msg)++-- | From a raw JSON response body and status code to the interpreted displayed text+getErrorText :: ByteString -> Status -> Text+getErrorText body status = showGitlabException $ VanillaHttpException $ HttpExceptionRequest defaultRequest (StatusCodeException (dummyResponse status) (toStrict body))