{-# 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 (Eq, Show)
data IssueStatus = Open | Closed deriving (Eq, Show)
data GitIssueRef
= GitIssueRef
{ server :: GitServer,
owner :: Text,
repo :: Text,
issueNum :: Int
}
deriving (Eq, Show)
data GitIssueData
= GitIssueData
{ gitIssue :: Localized GitIssueRef,
issueStatus :: IssueStatus,
issueTitle :: Text
}
deriving (Eq, Show)
serverDomain ::
GitServer ->
Text
serverDomain Github = "github.com"
serverDomain (Gitlab (GitlabHost h)) = h
gitRepoRe :: RE.Regex
gitRepoRe = [RE.re|\b(?>https?://)?(?>www\.)?([^/ ]+)/([^ ]+)/([^- ][^/ ]*)(?>/-)?/issues/([0-9]+)|]
extractIssuesOnALine :: ByteString -> [(Int, GitIssueRef)]
extractIssuesOnALine lineContent = map f (RE.scan gitRepoRe lineContent)
where
f (match, [domain, owner, repo, ByteString.readInt -> Just (issueNo, _)]) = (colNo, GitIssueRef provider (Text.Encoding.decodeUtf8 owner) (Text.Encoding.decodeUtf8 repo) issueNo)
where
colNo = 1 + ByteString.length (fst $ ByteString.breakSubstring match lineContent)
provider
| domain == "github.com" = Github
| otherwise = Gitlab (GitlabHost $ Text.Encoding.decodeUtf8 domain)
f res = error ("Error: impossible match" <> show res)
extractIssues ::
FilePath ->
ByteString ->
[Localized GitIssueRef]
extractIssues filePath toCheck = concat (zipWith extract [1 ..] (ByteString.lines toCheck))
where
extract lineNo lineContent = map f (extractIssuesOnALine lineContent)
where
f (colNo, gitIssue) = Localized (SourcePos filePath lineNo colNo) gitIssue
issueUrl ::
GitIssueRef ->
Req.Url 'Req.Https
issueUrl issue = case server issue of
Github -> Req.https "api.github.com" Req./: "repos" Req./: owner issue Req./: repo issue Req./: "issues" Req./~ issueNum issue
Gitlab (GitlabHost host) -> Req.https host Req./: "api" Req./: "v4" Req./: "projects" Req./: [fmt|{owner issue}/{repo issue}|] Req./: "issues" Req./~ issueNum issue
tryRestIssue ::
MonadKrank m =>
Localized GitIssueRef ->
m Value
tryRestIssue locIssue = do
let issue = unLocalized locIssue
let url = issueUrl issue
headers <- headersFor issue
krankRunRESTRequest url headers
headersFor ::
MonadKrank m =>
GitIssueRef ->
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)}|])]
showGitServerException ::
GitServer ->
Req.HttpException ->
Text
showGitServerException Github exc = showGithubException exc
showGitServerException (Gitlab _) exc = showGitlabException exc
restIssue ::
MonadKrank m =>
Localized GitIssueRef ->
m Value
restIssue issue = catch (tryRestIssue issue) (httpExcHandler . server . unLocalized $ issue)
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
"opened" -> Right Open
_ -> Left [fmt|Could not parse status '{status}'|]
readState (AesonT.Error _) = Left $ errorParser o
statusParser _ = Left "invalid JSON"
titleParser ::
Value ->
Either Text Text
titleParser (AesonT.Object o) = do
let title :: AesonT.Result String = AesonT.parse (.: "title") o
Right $ readTitle title
where
readTitle (AesonT.Success title) = pack title
readTitle (AesonT.Error _) = "invalid JSON"
titleParser _ = Left "invalid JSON"
errorParser ::
AesonT.Object ->
Text
errorParser o = do
let err = AesonT.parse (.: "error") o
readErr err
where
readErr (AesonT.Success errText) = pack errText
readErr (AesonT.Error _) = "invalid JSON"
gitIssuesWithStatus ::
MonadKrank m =>
[Localized GitIssueRef] ->
m [Either (Text, Localized GitIssueRef) GitIssueData]
gitIssuesWithStatus issues = do
jsonData <- krankMapConcurrently restIssue issues
let statuses = fmap statusParser jsonData
let titles = fmap titleParser jsonData
pure $ zipWith3 f issues statuses titles
where
f issue (Left err) _ = Left (err, issue)
f issue _ (Left err) = Left (err, issue)
f issue (Right status) (Right title) = Right $ GitIssueData issue status title
issueToLevel ::
GitIssueData ->
ViolationLevel
issueToLevel i = case issueStatus i of
Open -> Info
Closed -> Error
issueToMessage ::
GitIssueData ->
Text
issueToMessage i =
case issueStatus i of
Open -> [fmt|the issue is still Open\ntitle: {title}|]
Closed -> [fmt|the issue is now Closed - You can remove the workaround you used there\ntitle: {title}|]
where
title = issueTitle i
issuePrintUrl :: GitIssueRef -> Text
issuePrintUrl GitIssueRef {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
isDryRun <- krankAsks dryRun
if isDryRun
then
pure $
fmap
( \issue ->
Violation
{ checker = issuePrintUrl . unLocalized $ issue,
level = Info,
message = "Dry run",
location = getLocation (issue :: Localized GitIssueRef)
}
)
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 GitIssueRef)
}
f (Right issue) =
Violation
{ checker = issuePrintUrl (unLocalized . gitIssue $ issue),
level = issueToLevel issue,
message = issueToMessage issue,
location = getLocation (gitIssue issue :: Localized GitIssueRef)
}