{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

module Krank.Checkers.IssueTracker
  ( GitIssueRef (..),
    GitServer (..),
    Localized (..),
    checkText,
    extractIssues,
    gitRepoRe,
    serverDomain,
    extractIssuesOnALine,
  )
where

import Control.Exception.Safe (catch)
import Data.Aeson ((.:), Value)
import qualified Data.Aeson.Types as AesonT
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 qualified Text.Regex.PCRE.Heavy as RE
import Utils.Github (showGithubException)
import Utils.Gitlab (showGitlabException)

data GitServer = Github | Gitlab GitlabHost
  deriving (GitServer -> GitServer -> Bool
(GitServer -> GitServer -> Bool)
-> (GitServer -> GitServer -> Bool) -> Eq GitServer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GitServer -> GitServer -> Bool
$c/= :: GitServer -> GitServer -> Bool
== :: GitServer -> GitServer -> Bool
$c== :: GitServer -> GitServer -> Bool
Eq, Int -> GitServer -> ShowS
[GitServer] -> ShowS
GitServer -> String
(Int -> GitServer -> ShowS)
-> (GitServer -> String)
-> ([GitServer] -> ShowS)
-> Show GitServer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GitServer] -> ShowS
$cshowList :: [GitServer] -> ShowS
show :: GitServer -> String
$cshow :: GitServer -> String
showsPrec :: Int -> GitServer -> ShowS
$cshowsPrec :: Int -> GitServer -> ShowS
Show)

data IssueStatus = Open | Closed deriving (IssueStatus -> IssueStatus -> Bool
(IssueStatus -> IssueStatus -> Bool)
-> (IssueStatus -> IssueStatus -> Bool) -> Eq IssueStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IssueStatus -> IssueStatus -> Bool
$c/= :: IssueStatus -> IssueStatus -> Bool
== :: IssueStatus -> IssueStatus -> Bool
$c== :: IssueStatus -> IssueStatus -> Bool
Eq, Int -> IssueStatus -> ShowS
[IssueStatus] -> ShowS
IssueStatus -> String
(Int -> IssueStatus -> ShowS)
-> (IssueStatus -> String)
-> ([IssueStatus] -> ShowS)
-> Show IssueStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IssueStatus] -> ShowS
$cshowList :: [IssueStatus] -> ShowS
show :: IssueStatus -> String
$cshow :: IssueStatus -> String
showsPrec :: Int -> IssueStatus -> ShowS
$cshowsPrec :: Int -> IssueStatus -> ShowS
Show)

data GitIssueRef
  = GitIssueRef
      { GitIssueRef -> GitServer
server :: GitServer,
        GitIssueRef -> Text
owner :: Text,
        GitIssueRef -> Text
repo :: Text,
        GitIssueRef -> Int
issueNum :: Int
      }
  deriving (GitIssueRef -> GitIssueRef -> Bool
(GitIssueRef -> GitIssueRef -> Bool)
-> (GitIssueRef -> GitIssueRef -> Bool) -> Eq GitIssueRef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GitIssueRef -> GitIssueRef -> Bool
$c/= :: GitIssueRef -> GitIssueRef -> Bool
== :: GitIssueRef -> GitIssueRef -> Bool
$c== :: GitIssueRef -> GitIssueRef -> Bool
Eq, Int -> GitIssueRef -> ShowS
[GitIssueRef] -> ShowS
GitIssueRef -> String
(Int -> GitIssueRef -> ShowS)
-> (GitIssueRef -> String)
-> ([GitIssueRef] -> ShowS)
-> Show GitIssueRef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GitIssueRef] -> ShowS
$cshowList :: [GitIssueRef] -> ShowS
show :: GitIssueRef -> String
$cshow :: GitIssueRef -> String
showsPrec :: Int -> GitIssueRef -> ShowS
$cshowsPrec :: Int -> GitIssueRef -> ShowS
Show)

data GitIssueData
  = GitIssueData
      { GitIssueData -> Localized GitIssueRef
gitIssue :: Localized GitIssueRef,
        GitIssueData -> IssueStatus
issueStatus :: IssueStatus,
        GitIssueData -> Text
issueTitle :: Text
      }
  deriving (GitIssueData -> GitIssueData -> Bool
(GitIssueData -> GitIssueData -> Bool)
-> (GitIssueData -> GitIssueData -> Bool) -> Eq GitIssueData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GitIssueData -> GitIssueData -> Bool
$c/= :: GitIssueData -> GitIssueData -> Bool
== :: GitIssueData -> GitIssueData -> Bool
$c== :: GitIssueData -> GitIssueData -> Bool
Eq, Int -> GitIssueData -> ShowS
[GitIssueData] -> ShowS
GitIssueData -> String
(Int -> GitIssueData -> ShowS)
-> (GitIssueData -> String)
-> ([GitIssueData] -> ShowS)
-> Show GitIssueData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GitIssueData] -> ShowS
$cshowList :: [GitIssueData] -> ShowS
show :: GitIssueData -> String
$cshow :: GitIssueData -> String
showsPrec :: Int -> GitIssueData -> ShowS
$cshowsPrec :: Int -> GitIssueData -> ShowS
Show)

serverDomain ::
  GitServer ->
  Text
serverDomain :: GitServer -> Text
serverDomain GitServer
Github = Text
"github.com"
serverDomain (Gitlab (GitlabHost Text
h)) = Text
h

-- | 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 :: Regex
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, GitIssueRef)]
extractIssuesOnALine :: ByteString -> [(Int, GitIssueRef)]
extractIssuesOnALine ByteString
lineContent = ((ByteString, [ByteString]) -> (Int, GitIssueRef))
-> [(ByteString, [ByteString])] -> [(Int, GitIssueRef)]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, [ByteString]) -> (Int, GitIssueRef)
f (Regex -> ByteString -> [(ByteString, [ByteString])]
forall a.
(ConvertibleStrings ByteString a,
 ConvertibleStrings a ByteString) =>
Regex -> a -> [(a, [a])]
RE.scan Regex
gitRepoRe ByteString
lineContent)
  where
    f :: (ByteString, [ByteString]) -> (Int, GitIssueRef)
f (ByteString
match, [ByteString
domain, ByteString
owner, ByteString
repo, ByteString -> Maybe (Int, ByteString)
ByteString.readInt -> Just (Int
issueNo, ByteString
_)]) = (Int
colNo, GitServer -> Text -> Text -> Int -> GitIssueRef
GitIssueRef GitServer
provider (ByteString -> Text
Text.Encoding.decodeUtf8 ByteString
owner) (ByteString -> Text
Text.Encoding.decodeUtf8 ByteString
repo) Int
issueNo)
      where
        colNo :: Int
colNo = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
ByteString.length ((ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> (ByteString, ByteString)
ByteString.breakSubstring ByteString
match ByteString
lineContent)
        provider :: GitServer
provider
          | ByteString
domain ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"github.com" = GitServer
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.
          | Bool
otherwise = GitlabHost -> GitServer
Gitlab (Text -> GitlabHost
GitlabHost (Text -> GitlabHost) -> Text -> GitlabHost
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
Text.Encoding.decodeUtf8 ByteString
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 (ByteString, [ByteString])
res = String -> (Int, GitIssueRef)
forall a. HasCallStack => String -> a
error (String
"Error: impossible match" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (ByteString, [ByteString]) -> String
forall a. Show a => a -> String
show (ByteString, [ByteString])
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 GitIssueRef]
extractIssues :: String -> ByteString -> [Localized GitIssueRef]
extractIssues String
filePath ByteString
toCheck = [[Localized GitIssueRef]] -> [Localized GitIssueRef]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Int -> ByteString -> [Localized GitIssueRef])
-> [Int] -> [ByteString] -> [[Localized GitIssueRef]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> ByteString -> [Localized GitIssueRef]
extract [Int
1 ..] (ByteString -> [ByteString]
ByteString.lines ByteString
toCheck))
  where
    extract :: Int -> ByteString -> [Localized GitIssueRef]
extract Int
lineNo ByteString
lineContent = ((Int, GitIssueRef) -> Localized GitIssueRef)
-> [(Int, GitIssueRef)] -> [Localized GitIssueRef]
forall a b. (a -> b) -> [a] -> [b]
map (Int, GitIssueRef) -> Localized GitIssueRef
forall t. (Int, t) -> Localized t
f (ByteString -> [(Int, GitIssueRef)]
extractIssuesOnALine ByteString
lineContent)
      where
        f :: (Int, t) -> Localized t
f (Int
colNo, t
gitIssue) = SourcePos -> t -> Localized t
forall t. SourcePos -> t -> Localized t
Localized (String -> Int -> Int -> SourcePos
SourcePos String
filePath Int
lineNo Int
colNo) t
gitIssue

-- Supports only github for the moment
issueUrl ::
  GitIssueRef ->
  Req.Url 'Req.Https
issueUrl :: GitIssueRef -> Url 'Https
issueUrl GitIssueRef
issue = case GitIssueRef -> GitServer
server GitIssueRef
issue of
  GitServer
Github -> Text -> Url 'Https
Req.https Text
"api.github.com" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
Req./: Text
"repos" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
Req./: GitIssueRef -> Text
owner GitIssueRef
issue Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
Req./: GitIssueRef -> Text
repo GitIssueRef
issue Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
Req./: Text
"issues" Url 'Https -> Int -> Url 'Https
forall a (scheme :: Scheme).
ToHttpApiData a =>
Url scheme -> a -> Url scheme
Req./~ GitIssueRef -> Int
issueNum GitIssueRef
issue
  Gitlab (GitlabHost Text
host) -> Text -> Url 'Https
Req.https Text
host Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
Req./: Text
"api" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
Req./: Text
"v4" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
Req./: Text
"projects" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
Req./: [fmt|{owner issue}/{repo issue}|] Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
Req./: Text
"issues" Url 'Https -> Int -> Url 'Https
forall a (scheme :: Scheme).
ToHttpApiData a =>
Url scheme -> a -> Url scheme
Req./~ GitIssueRef -> Int
issueNum GitIssueRef
issue

-- try Issue can fail, on non-2xx HTTP response
tryRestIssue ::
  MonadKrank m =>
  Localized GitIssueRef ->
  m Value
tryRestIssue :: Localized GitIssueRef -> m Value
tryRestIssue Localized GitIssueRef
locIssue = do
  let issue :: GitIssueRef
issue = Localized GitIssueRef -> GitIssueRef
forall t. Localized t -> t
unLocalized Localized GitIssueRef
locIssue
  let url :: Url 'Https
url = GitIssueRef -> Url 'Https
issueUrl GitIssueRef
issue
  Option 'Https
headers <- GitIssueRef -> m (Option 'Https)
forall (m :: * -> *).
MonadKrank m =>
GitIssueRef -> m (Option 'Https)
headersFor GitIssueRef
issue
  Url 'Https -> Option 'Https -> m Value
forall (m :: * -> *) t.
(MonadKrank m, FromJSON t) =>
Url 'Https -> Option 'Https -> m t
krankRunRESTRequest Url 'Https
url Option 'Https
headers

headersFor ::
  MonadKrank m =>
  GitIssueRef ->
  m (Req.Option 'Req.Https)
headersFor :: GitIssueRef -> m (Option 'Https)
headersFor GitIssueRef
issue = do
  Maybe GithubKey
mGithubKey <- (KrankConfig -> Maybe GithubKey) -> m (Maybe GithubKey)
forall (m :: * -> *) b. MonadKrank m => (KrankConfig -> b) -> m b
krankAsks KrankConfig -> Maybe GithubKey
githubKey
  Map GitlabHost GitlabKey
mGitlabKeys <- (KrankConfig -> Map GitlabHost GitlabKey)
-> m (Map GitlabHost GitlabKey)
forall (m :: * -> *) b. MonadKrank m => (KrankConfig -> b) -> m b
krankAsks KrankConfig -> Map GitlabHost GitlabKey
gitlabKeys
  case GitIssueRef -> GitServer
server GitIssueRef
issue of
    GitServer
Github -> case Maybe GithubKey
mGithubKey of
      Just (GithubKey Text
token) -> Option 'Https -> m (Option 'Https)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Option 'Https -> m (Option 'Https))
-> Option 'Https -> m (Option 'Https)
forall a b. (a -> b) -> a -> b
$ ByteString -> Option 'Https
Req.oAuth2Token (Text -> ByteString
Text.Encoding.encodeUtf8 Text
token)
      Maybe GithubKey
Nothing -> Option 'Https -> m (Option 'Https)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Option 'Https
forall a. Monoid a => a
mempty
    Gitlab GitlabHost
host -> case GitlabHost -> Map GitlabHost GitlabKey -> Maybe GitlabKey
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GitlabHost
host Map GitlabHost GitlabKey
mGitlabKeys of
      Just (GitlabKey Text
token) -> Option 'Https -> m (Option 'Https)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Option 'Https -> m (Option 'Https))
-> Option 'Https -> m (Option 'Https)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Option 'Https
forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
Req.header ByteString
"PRIVATE-TOKEN" (Text -> ByteString
Text.Encoding.encodeUtf8 Text
token)
      Maybe GitlabKey
Nothing -> Option 'Https -> m (Option 'Https)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Option 'Https
forall a. Monoid a => a
mempty

httpExcHandler ::
  MonadKrank m =>
  GitServer ->
  Req.HttpException ->
  m Value
httpExcHandler :: GitServer -> HttpException -> m Value
httpExcHandler GitServer
gitServer HttpException
exc =
  Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> m Value) -> ([Pair] -> Value) -> [Pair] -> m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pair] -> Value
AesonT.object ([Pair] -> m Value) -> [Pair] -> m Value
forall a b. (a -> b) -> a -> b
$ [(Text
"error", Text -> Value
AesonT.String (Text -> Value) -> (String -> Text) -> String -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ [fmt|{(showGitServerException gitServer exc)}|])]

showGitServerException ::
  GitServer ->
  Req.HttpException ->
  Text
showGitServerException :: GitServer -> HttpException -> Text
showGitServerException GitServer
Github HttpException
exc = HttpException -> Text
showGithubException HttpException
exc
showGitServerException (Gitlab GitlabHost
_) HttpException
exc = HttpException -> Text
showGitlabException HttpException
exc

restIssue ::
  MonadKrank m =>
  Localized GitIssueRef ->
  m Value
restIssue :: Localized GitIssueRef -> m Value
restIssue Localized GitIssueRef
issue = m Value -> (HttpException -> m Value) -> m Value
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (Localized GitIssueRef -> m Value
forall (m :: * -> *).
MonadKrank m =>
Localized GitIssueRef -> m Value
tryRestIssue Localized GitIssueRef
issue) (GitServer -> HttpException -> m Value
forall (m :: * -> *).
MonadKrank m =>
GitServer -> HttpException -> m Value
httpExcHandler (GitServer -> HttpException -> m Value)
-> (Localized GitIssueRef -> GitServer)
-> Localized GitIssueRef
-> HttpException
-> m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GitIssueRef -> GitServer
server (GitIssueRef -> GitServer)
-> (Localized GitIssueRef -> GitIssueRef)
-> Localized GitIssueRef
-> GitServer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Localized GitIssueRef -> GitIssueRef
forall t. Localized t -> t
unLocalized (Localized GitIssueRef -> HttpException -> m Value)
-> Localized GitIssueRef -> HttpException -> m Value
forall a b. (a -> b) -> a -> b
$ Localized GitIssueRef
issue)

statusParser ::
  Value ->
  Either Text IssueStatus
statusParser :: Value -> Either Text IssueStatus
statusParser (AesonT.Object Object
o) = do
  let Result String
state :: AesonT.Result String = (Object -> Parser String) -> Object -> Result String
forall a b. (a -> Parser b) -> a -> Result b
AesonT.parse (Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"state") Object
o
  Result String -> Either Text IssueStatus
forall i.
(Eq i, IsString i, FormatAny2 (PyFClassify i) i 'AlignAll) =>
Result i -> Either Text IssueStatus
readState Result String
state
  where
    readState :: Result i -> Either Text IssueStatus
readState (AesonT.Success i
status) = case i
status of
      i
"closed" -> IssueStatus -> Either Text IssueStatus
forall a b. b -> Either a b
Right IssueStatus
Closed -- Both Gitlab and Github use the same keyword for closed
      i
"open" -> IssueStatus -> Either Text IssueStatus
forall a b. b -> Either a b
Right IssueStatus
Open -- Github uses the 'open' status
      i
"opened" -> IssueStatus -> Either Text IssueStatus
forall a b. b -> Either a b
Right IssueStatus
Open -- Gitlab uses the 'opened' status
      i
_ -> Text -> Either Text IssueStatus
forall a b. a -> Either a b
Left [fmt|Could not parse status '{status}'|]
    readState (AesonT.Error String
_) = Text -> Either Text IssueStatus
forall a b. a -> Either a b
Left (Text -> Either Text IssueStatus)
-> Text -> Either Text IssueStatus
forall a b. (a -> b) -> a -> b
$ Object -> Text
errorParser Object
o
statusParser Value
_ = Text -> Either Text IssueStatus
forall a b. a -> Either a b
Left Text
"invalid JSON"

titleParser ::
  Value ->
  Either Text Text
titleParser :: Value -> Either Text Text
titleParser (AesonT.Object Object
o) = do
  let Result String
title :: AesonT.Result String = (Object -> Parser String) -> Object -> Result String
forall a b. (a -> Parser b) -> a -> Result b
AesonT.parse (Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"title") Object
o
  Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Result String -> Text
readTitle Result String
title
  where
    readTitle :: Result String -> Text
readTitle (AesonT.Success String
title) = String -> Text
pack String
title
    readTitle (AesonT.Error String
_) = Text
"invalid JSON"
titleParser Value
_ = Text -> Either Text Text
forall a b. a -> Either a b
Left Text
"invalid JSON"

errorParser ::
  AesonT.Object ->
  Text
errorParser :: Object -> Text
errorParser Object
o = do
  let err :: Result String
err = (Object -> Parser String) -> Object -> Result String
forall a b. (a -> Parser b) -> a -> Result b
AesonT.parse (Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"error") Object
o
  Result String -> Text
readErr Result String
err
  where
    readErr :: Result String -> Text
readErr (AesonT.Success String
errText) = String -> Text
pack String
errText
    readErr (AesonT.Error String
_) = Text
"invalid JSON"

gitIssuesWithStatus ::
  MonadKrank m =>
  [Localized GitIssueRef] ->
  m [Either (Text, Localized GitIssueRef) GitIssueData]
gitIssuesWithStatus :: [Localized GitIssueRef]
-> m [Either (Text, Localized GitIssueRef) GitIssueData]
gitIssuesWithStatus [Localized GitIssueRef]
issues = do
  [Value]
jsonData <- (Localized GitIssueRef -> m Value)
-> [Localized GitIssueRef] -> m [Value]
forall (m :: * -> *) a b.
MonadKrank m =>
(a -> m b) -> [a] -> m [b]
krankMapConcurrently Localized GitIssueRef -> m Value
forall (m :: * -> *).
MonadKrank m =>
Localized GitIssueRef -> m Value
restIssue [Localized GitIssueRef]
issues
  let statuses :: [Either Text IssueStatus]
statuses = (Value -> Either Text IssueStatus)
-> [Value] -> [Either Text IssueStatus]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Either Text IssueStatus
statusParser [Value]
jsonData
  let titles :: [Either Text Text]
titles = (Value -> Either Text Text) -> [Value] -> [Either Text Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Either Text Text
titleParser [Value]
jsonData
  [Either (Text, Localized GitIssueRef) GitIssueData]
-> m [Either (Text, Localized GitIssueRef) GitIssueData]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Either (Text, Localized GitIssueRef) GitIssueData]
 -> m [Either (Text, Localized GitIssueRef) GitIssueData])
-> [Either (Text, Localized GitIssueRef) GitIssueData]
-> m [Either (Text, Localized GitIssueRef) GitIssueData]
forall a b. (a -> b) -> a -> b
$ (Localized GitIssueRef
 -> Either Text IssueStatus
 -> Either Text Text
 -> Either (Text, Localized GitIssueRef) GitIssueData)
-> [Localized GitIssueRef]
-> [Either Text IssueStatus]
-> [Either Text Text]
-> [Either (Text, Localized GitIssueRef) GitIssueData]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Localized GitIssueRef
-> Either Text IssueStatus
-> Either Text Text
-> Either (Text, Localized GitIssueRef) GitIssueData
forall a.
Localized GitIssueRef
-> Either a IssueStatus
-> Either a Text
-> Either (a, Localized GitIssueRef) GitIssueData
f [Localized GitIssueRef]
issues [Either Text IssueStatus]
statuses [Either Text Text]
titles
  where
    f :: Localized GitIssueRef
-> Either a IssueStatus
-> Either a Text
-> Either (a, Localized GitIssueRef) GitIssueData
f Localized GitIssueRef
issue (Left a
err) Either a Text
_ = (a, Localized GitIssueRef)
-> Either (a, Localized GitIssueRef) GitIssueData
forall a b. a -> Either a b
Left (a
err, Localized GitIssueRef
issue)
    f Localized GitIssueRef
issue Either a IssueStatus
_ (Left a
err) = (a, Localized GitIssueRef)
-> Either (a, Localized GitIssueRef) GitIssueData
forall a b. a -> Either a b
Left (a
err, Localized GitIssueRef
issue)
    f Localized GitIssueRef
issue (Right IssueStatus
status) (Right Text
title) = GitIssueData -> Either (a, Localized GitIssueRef) GitIssueData
forall a b. b -> Either a b
Right (GitIssueData -> Either (a, Localized GitIssueRef) GitIssueData)
-> GitIssueData -> Either (a, Localized GitIssueRef) GitIssueData
forall a b. (a -> b) -> a -> b
$ Localized GitIssueRef -> IssueStatus -> Text -> GitIssueData
GitIssueData Localized GitIssueRef
issue IssueStatus
status Text
title

issueToLevel ::
  GitIssueData ->
  ViolationLevel
issueToLevel :: GitIssueData -> ViolationLevel
issueToLevel GitIssueData
i = case GitIssueData -> IssueStatus
issueStatus GitIssueData
i of
  IssueStatus
Open -> ViolationLevel
Info
  IssueStatus
Closed -> ViolationLevel
Error

issueToMessage ::
  GitIssueData ->
  Text
issueToMessage :: GitIssueData -> Text
issueToMessage GitIssueData
i =
  case GitIssueData -> IssueStatus
issueStatus GitIssueData
i of
    IssueStatus
Open -> [fmt|the issue is still Open\ntitle: {title}|]
    IssueStatus
Closed -> [fmt|the issue is now Closed - You can remove the workaround you used there\ntitle: {title}|]
  where
    title :: Text
title = GitIssueData -> Text
issueTitle GitIssueData
i

issuePrintUrl :: GitIssueRef -> Text
issuePrintUrl :: GitIssueRef -> Text
issuePrintUrl GitIssueRef {Text
owner :: Text
$sel:owner:GitIssueRef :: GitIssueRef -> Text
owner, Text
repo :: Text
$sel:repo:GitIssueRef :: GitIssueRef -> Text
repo, GitServer
server :: GitServer
$sel:server:GitIssueRef :: GitIssueRef -> GitServer
server, Int
issueNum :: Int
$sel:issueNum:GitIssueRef :: GitIssueRef -> Int
issueNum} = [fmt|IssueTracker check for https://{serverDomain server}/{owner}/{repo}/issues/{issueNum}|]

checkText ::
  MonadKrank m =>
  FilePath ->
  ByteString ->
  m [Violation]
checkText :: String -> ByteString -> m [Violation]
checkText String
path ByteString
t = do
  let issues :: [Localized GitIssueRef]
issues = String -> ByteString -> [Localized GitIssueRef]
extractIssues String
path ByteString
t
  Bool
isDryRun <- (KrankConfig -> Bool) -> m Bool
forall (m :: * -> *) b. MonadKrank m => (KrankConfig -> b) -> m b
krankAsks KrankConfig -> Bool
dryRun
  if Bool
isDryRun
    then
      [Violation] -> m [Violation]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Violation] -> m [Violation]) -> [Violation] -> m [Violation]
forall a b. (a -> b) -> a -> b
$
        (Localized GitIssueRef -> Violation)
-> [Localized GitIssueRef] -> [Violation]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
          ( \Localized GitIssueRef
issue ->
              Violation :: Text -> ViolationLevel -> Text -> SourcePos -> Violation
Violation
                { checker :: Text
checker = GitIssueRef -> Text
issuePrintUrl (GitIssueRef -> Text)
-> (Localized GitIssueRef -> GitIssueRef)
-> Localized GitIssueRef
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Localized GitIssueRef -> GitIssueRef
forall t. Localized t -> t
unLocalized (Localized GitIssueRef -> Text) -> Localized GitIssueRef -> Text
forall a b. (a -> b) -> a -> b
$ Localized GitIssueRef
issue,
                  level :: ViolationLevel
level = ViolationLevel
Info,
                  message :: Text
message = Text
"Dry run",
                  location :: SourcePos
location = Localized GitIssueRef -> SourcePos
forall t. Localized t -> SourcePos
getLocation (Localized GitIssueRef
issue :: Localized GitIssueRef)
                }
          )
          [Localized GitIssueRef]
issues
    else do
      [Either (Text, Localized GitIssueRef) GitIssueData]
issuesWithStatus <- [Localized GitIssueRef]
-> m [Either (Text, Localized GitIssueRef) GitIssueData]
forall (m :: * -> *).
MonadKrank m =>
[Localized GitIssueRef]
-> m [Either (Text, Localized GitIssueRef) GitIssueData]
gitIssuesWithStatus [Localized GitIssueRef]
issues
      [Violation] -> m [Violation]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Violation] -> m [Violation]) -> [Violation] -> m [Violation]
forall a b. (a -> b) -> a -> b
$ (Either (Text, Localized GitIssueRef) GitIssueData -> Violation)
-> [Either (Text, Localized GitIssueRef) GitIssueData]
-> [Violation]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either (Text, Localized GitIssueRef) GitIssueData -> Violation
f [Either (Text, Localized GitIssueRef) GitIssueData]
issuesWithStatus
  where
    f :: Either (Text, Localized GitIssueRef) GitIssueData -> Violation
f (Left (Text
err, Localized GitIssueRef
issue)) =
      Violation :: Text -> ViolationLevel -> Text -> SourcePos -> Violation
Violation
        { checker :: Text
checker = GitIssueRef -> Text
issuePrintUrl (GitIssueRef -> Text)
-> (Localized GitIssueRef -> GitIssueRef)
-> Localized GitIssueRef
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Localized GitIssueRef -> GitIssueRef
forall t. Localized t -> t
unLocalized (Localized GitIssueRef -> Text) -> Localized GitIssueRef -> Text
forall a b. (a -> b) -> a -> b
$ Localized GitIssueRef
issue,
          level :: ViolationLevel
level = ViolationLevel
Warning,
          message :: Text
message = Text
"Error when calling the API:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err,
          location :: SourcePos
location = Localized GitIssueRef -> SourcePos
forall t. Localized t -> SourcePos
getLocation (Localized GitIssueRef
issue :: Localized GitIssueRef)
        }
    f (Right GitIssueData
issue) =
      Violation :: Text -> ViolationLevel -> Text -> SourcePos -> Violation
Violation
        { checker :: Text
checker = GitIssueRef -> Text
issuePrintUrl (Localized GitIssueRef -> GitIssueRef
forall t. Localized t -> t
unLocalized (Localized GitIssueRef -> GitIssueRef)
-> (GitIssueData -> Localized GitIssueRef)
-> GitIssueData
-> GitIssueRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GitIssueData -> Localized GitIssueRef
gitIssue (GitIssueData -> GitIssueRef) -> GitIssueData -> GitIssueRef
forall a b. (a -> b) -> a -> b
$ GitIssueData
issue),
          level :: ViolationLevel
level = GitIssueData -> ViolationLevel
issueToLevel GitIssueData
issue,
          message :: Text
message = GitIssueData -> Text
issueToMessage GitIssueData
issue,
          location :: SourcePos
location = Localized GitIssueRef -> SourcePos
forall t. Localized t -> SourcePos
getLocation (GitIssueData -> Localized GitIssueRef
gitIssue GitIssueData
issue :: Localized GitIssueRef)
        }