diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,33 @@ Checkmate changelog =================== +Version 0.3.0 +------------- + +Released on October 21, 2017. + +### Frontend + + - Added a new filename *.check* besides *CHECK* as directory-level checklist + file. + + - `checkmate github` command became to leave no comment when there are + nothing to `CHECK` corresponding to the given diff. It also removes + the existing comment previously left by Checkmate on the same pull request. + + - Added `checkmate github-travis` and `checkmate github-circle` commands, + shortcuts of `checkmate github` for Travis CI and Circle CI integration. + It even doesn't need the result of `git diff`. + + - `checkmate` and its subcommands became to terminate with a proper non-zero + exit code and print messages to /dev/stderr instead of /dev/stdout when + it fails to read diff. + +### Internals + + - Added `Checkmate.Publisher` and `Checkmate.Publisher.GitHub` module. + + Version 0.2.1 ------------- @@ -76,14 +103,14 @@ Released on September 20, 2017. -### Program +### Frontend - Checklist texts generated by `checkmate commonmark`, `checkmate gfm`, and `checkmate github` became to have two levels of headings. The top-level heading is still the title of the checklist as it has been, and the second-level heading is a corresponding file path of its following checks. -### Library +### Internals - Added `Checkmate.Renderer` module. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,9 +4,202 @@ [![Build Status][ci-badge]][ci] [![Hackage][hackage-badge]][hackage] -Generate checklists relevant to a given patch. +Checkmate is a small program to generate human-readable checklists from +a given patch (or pull request). Leave `CHECK` comments (that are the same +fashion as `FIXME` or `TODO` comments); then Checkmate detects when a diff +touches some code scopes having any `CHECK` comments, and lists the checks. +It helps contributors and reviewers to remind matters that require attention +when a part of the code is changed. + + +Situation +--------- + +Let's say there's a dictionary, and we should update the manual when a key +is added to or removed from it: + +~~~~~~~~ python +TARGET_LANGUAGES = { + # CHECK: Please update the manual on the project wiki when you add/remove + # a language. + + 'c': '*.c', + 'java': '*.java', + 'javascript': '*.js', + 'python': '*.py', +} +~~~~~~~~ + +The above example may be artificial, but suppose lines of the dictionary are +lengthy. Such tasks should be done outside of the source code repository +so that they cannot be automated by simply eliminating code duplicates. +Contributors and reviewers altogether are easy to forget about such tasks. + +To remind peers of such tasks, Checkmate detects `CHECK` comments like the above +example when a relevant *code block* is touched and show peers a checklist. + [ci-badge]: https://travis-ci.org/spoqa/checkmate.svg?branch=master [ci]: https://travis-ci.org/spoqa/checkmate [hackage-badge]: https://img.shields.io/hackage/v/checkmate.svg [hackage]: https://hackage.haskell.org/package/checkmate + + +Listing relevant checks: overlapped blocks +------------------------------------------ + +How does Checkmate list only relevant checks to a diff? It currently doesn't +have any language-specific algorithms, but only a language-agnostic heuristics +on indented blocks. + +Suppose the following diff: + +~~~~~~~~ diff +diff --git a/langs.py b/langs.py +--- a/langs.py ++++ b/langs.py +@@ -5,6 +5,7 @@ TARGET_LANGUAGES = { + 'c': '*.c', + 'java': '*.java', + 'javascript': '*.js', ++ 'haskell': '*.hs', + 'python': '*.py', + } + +~~~~~~~~ + +Since it touched a code block with a `CHECK` comment, Checkmate generates +the following checklist: + +> - Please update the manual on the project wiki when you add/remove a language. + +Suppose a patch touches only code blocks without any `CHECK` comments too, e.g.: + +~~~~~~~~ diff +diff --git a/langs.py b/langs.py +--- a/langs.py ++++ b/langs.py +@@ -8,6 +8,7 @@ TARGET_LANGUAGES = { + 'python': '*.py', + } + + OTHER_DATA = { + # This code block is not relevant to TARGET_LANGUAGES. ++ 'haskell': '*.hs', + } +~~~~~~~~ + +Since the touched block doesn't have any `CHECK` comments, Checkmate generates +an empty checklist. + +Note that it doesn't parse code's semantics, but only scans blocks through +indentation. Even if a block is wrapped in curly braces without indentation, +it isn't counted as a block. + + +Directory-level checklist +------------------------- + +Some checks may need to be listed for a whole directory. Checkmate recognizes +files named *.check* or *CHECK* in a directory and include checks in that to +the checklist if any file in the directory are changed. Its syntax is basically +a simple bullet list and a bullet can be `*`/`-`/`+`/`CHECK` or digits followed +by `.`/`)`, e.g.: + + - Check 1 + - Check 2 + + + A plus sign too can be a bullet. + * An asterisk too. + + 1. Numbered-bullets also can be used. + 2) A closing parenthesis as well can follow instead of a period. + + CHECK: For consistency `CHECK` keyword also can be a bullet as well. + CHECK And a colon can be omitted. + Lines without any bullet is continued from previous line(s). + + +Download +-------- + +We provide an official Linux x86_64 binary for [every release][]. See also +the [latest release][]. Note that official binaries are distributed as +statically-linked standalone executable, and they aren't gzipped. Download and +give an `+x` permission; then it's ready. + +On the other platforms you can download and install using Haskell [Cabal][] +or [Stack][] since source tarballs also are distributed on [Hackage][]: + +~~~~~~~~ bash +stack install checkmate +~~~~~~~~ + +[every release]: https://github.com/spoqa/checkmate/releases +[latest release]: https://github.com/spoqa/checkmate/releases/latest +[Cabal]: https://www.haskell.org/cabal/ +[Stack]: https://www.haskellstack.org/ + + +Integration with CI +------------------- + +Since Checkmate usually is executed as a part of CI build, we show examples +for widely-used CI services. + +All examples assume the environment variables are defined: + + - `GITHUB_TOKEN` contains the access token to leave comments on a + corresponding GitHub repository. See also GitHub's official article + about [personal API tokens][]. + - `CHECKMATE_DOWNLOAD_URL` contains the download link to the prebuilt binary + of the latest release, i.e.: + + ~~~~~~~ bash + CHECKMATE_DOWNLOAD_URL=https://github.com/spoqa/checkmate/releases/download/0.3.0/checkmate-linux-x86_64 + ~~~~~~~ + +[personal API tokens]: https://github.com/blog/1509-personal-api-tokens + + +### Travis CI + +~~~~~~~~ yaml +install: +- curl -L -o ~/bin/checkmate "$CHECKMATE_DOWNLOAD_URL" +- chmod +x ~/bin/checkmate +script: +- ~/bin/checkmate github-travis --token "$GITHUB_TOKEN" +~~~~~~~~ + + +### Circle CI + +~~~~~~~~ yaml +dependencies: + post: + - curl -L -o ~/bin/checkmate "$CHECKMATE_DOWNLOAD_URL" + - chmod +x ~/bin/checkmate +test: + post: + - ~/bin/checkmate github-circle --token "$GITHUB_TOKEN" +~~~~~~~~ + + +### Other CI softwares/services + +You can run `checkmate github` command with explicit arguments: + +~~~~~~~~ bash +curl -L -o ~/bin/checkmate "$CHECKMATE_DOWNLOAD_URL" +chmod +x ~/bin/checkmate +# Suppose we're running a build of github.com/foo/bar/pull/123 +~/bin/checkmate github \ + --token "$GITHUB_TOKEN" \ + --login foo \ + --repo bar \ + --pr 123 +~~~~~~~~ + +If you're using GitHub Enterprise on premise use `--endpoint` option. +Further reading: `checkmate github --help`. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -import Data.Foldable +import Control.Monad +import Data.List (elemIndices) +import Data.List.NonEmpty (nonEmpty, last) import Data.Maybe import Data.Semigroup ((<>)) import Prelude hiding (error) @@ -7,123 +9,149 @@ import System.Exit import System.IO -import Data.Text hiding (find) +import Data.Text import Data.Text.Encoding import Data.Text.IO as TIO -import GitHub.Auth -import GitHub.Data.Comments -import GitHub.Data.Definitions -import GitHub.Data.Id -import GitHub.Data.Issues -import GitHub.Data.Name -import GitHub.Data.Repos -import GitHub.Data.URL -import GitHub.Endpoints.Issues.Comments (comments', createComment, editComment) -import GitHub.Endpoints.Users (userInfoCurrent') import Options.Applicative import System.Directory +import System.Process hiding (cwd) import Checkmate.Check import Checkmate.Discover +import Checkmate.Publisher.GitHub import Checkmate.Renderer -type Command = App -> Checklist -> IO () +type InputReader = App -> IO Text +type CommandRunner = App -> Checklist -> IO () +data Command = Command + { inputReader :: InputReader + , commandRunner :: CommandRunner + } + data App = App - { inputFilePath :: FilePath + { inputFilePath :: Maybe FilePath , appCommand :: Command } withInputFile :: App -> (Handle -> IO r) -> IO r -withInputFile App { inputFilePath = "-" } action' = do +withInputFile App { inputFilePath = Nothing } action' = do let i = stdin r <- action' i hClose i return r -withInputFile App { inputFilePath = i } action' = +withInputFile app@App { inputFilePath = Just "-" } action' = + withInputFile (app { inputFilePath = Nothing }) action' +withInputFile App { inputFilePath = Just i } action' = withFile i ReadMode action' +readInputFile :: App -> IO Text +readInputFile = (`withInputFile` TIO.hGetContents) + +readDiff :: App -> IO (Either String FileDeltas) +readDiff app@App{ appCommand = Command { inputReader = readInput } } = + parseDiff <$> readInput app + +listChecks :: App -> IO Checklist +listChecks app = do + d <- readDiff app + cwd <- getCurrentDirectory + case d of + Left msg -> die msg + Right deltas -> discover cwd deltas + appP :: Parser App appP = App - <$> strOption ( long "input-file" - <> short 'i' - <> metavar "FILE" - <> showDefault - <> value "-" - <> help "A diff text to extract a checklist from" - ) + <$> option (Just <$> str) + ( long "input-file" + <> short 'i' + <> metavar "FILE" + <> value Nothing + <> help "A diff text to extract a checklist from" + ) <*> subparser ( command "commonmark" commonmarkPI <> command "gfm" gfmPI <> command "github" githubPI + <> command "github-circle" githubCirclePI + <> command "github-travis" githubTravisPI ) commonmarkPI :: ParserInfo Command -commonmarkPI = info (pure cmd) $ +commonmarkPI = info (pure $ Command readInputFile cmd) $ progDesc "Print a checklist as CommonMark (i.e. Markdown) format." where - cmd :: Command + cmd :: CommandRunner cmd _ checklist = do cwd <- getCurrentDirectory TIO.putStr $ toCommonMark cwd 1 checklist gfmPI :: ParserInfo Command -gfmPI = info (pure cmd) $ +gfmPI = info (pure $ Command readInputFile cmd) $ progDesc "Print a checklist as GitHub Flavored Markdown format." where - cmd :: Command + cmd :: CommandRunner cmd _ checklist = do cwd <- getCurrentDirectory TIO.putStr $ toGFMarkdown cwd 1 checklist +githubTokenOption :: Parser Token +githubTokenOption = option (encodeUtf8 . pack <$> str) + ( long "access-token" + <> long "token" + <> short 't' + <> metavar "TOKEN" + <> help "GitHub OAuth access token" + ) + +leaveGithubComment :: Maybe OwnerName + -> RepoName + -> PullRequestId + -> Token + -> Maybe Text + -> CommandRunner +leaveGithubComment owner' repo pr accessToken endpoint _ checklist = do + cwd <- getCurrentDirectory + r <- leaveComment owner' repo pr accessToken endpoint cwd checklist + case r of + Right Nothing -> return () + Right (Just (URL url)) -> TIO.putStrLn url + Left e -> handleGithubError e + +githubInputReader :: IO (Maybe OwnerName, RepoName, PullRequestId) + -> String + -> Token -> InputReader +githubInputReader identifier headEnvironKey accessToken (App Nothing _) = do + (owner, repo, prId) <- identifier + result <- pullRequestBaseSha owner repo prId accessToken Nothing + base <- case result of + Left e -> handleGithubError e + Right sha -> return sha + head' <- environ headEnvironKey + let range = unpack base ++ ".." ++ head' + diff <- readProcess "git" ["diff", range] "" + return $ pack diff +githubInputReader _ _ _ app = readInputFile app + +githubCommandRunner :: IO (Maybe OwnerName, RepoName, PullRequestId) + -> Token -> CommandRunner +githubCommandRunner identifier accessToken app checklist = do + (owner, repo, prId) <- identifier + leaveGithubComment owner repo prId accessToken Nothing app checklist + +handleGithubError :: Checkmate.Publisher.GitHub.Error -> IO a +handleGithubError (HTTPError httpError) = printError $ pack $ show httpError +handleGithubError (ParseError message) = printError message +handleGithubError (JsonError message) = printError message +handleGithubError (UserError message) = printError message + githubPI :: ParserInfo Command githubPI = info (parser <**> helper) $ progDesc $ "Create a checklist comment on the corresponding pull " ++ "reuqest on GitHub." where - cmd :: Maybe (Name Owner) - -> Name Repo - -> Id Issue - -> Token - -> Maybe Text - -> Command - cmd owner' repo pr accessToken endpoint _ checklist = do - user <- userInfoCurrent' auth >>= error - let owner = fromMaybe (N . untagName $ userLogin user) owner' - prComments <- comments' (Just auth) owner repo pr >>= error - let checklistComment = find (isChecklist user) prComments - leave = case checklistComment of - Nothing -> createComment auth owner repo pr - Just IssueComment { issueCommentId = cid } -> - editComment auth owner repo $ Id cid - cwd <- getCurrentDirectory - Comment { commentHtmlUrl = leftCommentUrl } <- - leave (signature `append` toGFMarkdown cwd 3 checklist) >>= error - case leftCommentUrl of - Just (URL u) -> TIO.putStrLn u - _ -> return () - where - auth :: Auth - auth = case endpoint of - Nothing -> OAuth accessToken - Just e -> EnterpriseOAuth e accessToken - signature :: Text - signature = "\n" - isChecklist :: User -> IssueComment -> Bool - isChecklist User { userId = uid } - IssueComment { issueCommentBody = cBody - , issueCommentUser = - SimpleUser { simpleUserId = authorId } - } = - uid == authorId && isPrefixOf signature cBody - error :: Either Error a -> IO a - error (Right v) = return v - error (Left (HTTPError httpError)) = printError $ pack $ show httpError - error (Left (ParseError message)) = printError message - error (Left (JsonError message)) = printError message - error (Left (UserError message)) = printError message parser :: Parser Command parser = cmd - <$> option (Just . (N :: Text -> Name Owner) . pack <$> str) + <$> option (Just . mkOwnerName . pack <$> str) ( long "owner" <> long "login" <> short 'l' @@ -134,7 +162,7 @@ "\"github.com/foo/bar\". The currently authenticated " ++ "user (through -t/--access-token/--token) by default") ) - <*> option ((N :: Text -> Name Repo) . pack <$> str) + <*> option (mkRepoName . pack <$> str) ( long "repository" <> long "repo" <> short 'r' @@ -142,20 +170,14 @@ <> help ("Name of GitHub repository of a pull request to create " ++ "a checklist comment. \"bar\" of \"github.com/foo/bar\"") ) - <*> option ((Id :: Int -> Id Issue) <$> (auto :: ReadM Int)) + <*> option (mkPullRequestId <$> (auto :: ReadM Int)) ( long "pull-request" <> long "pr" <> short 'p' <> metavar "NUM" <> help "No. of pull request to create a checklist comment" ) - <*> option (encodeUtf8 . pack <$> str) - ( long "access-token" - <> long "token" - <> short 't' - <> metavar "TOKEN" - <> help "GitHub OAuth access token" - ) + <*> githubTokenOption <*> option (Just . dropWhileEnd (== '/') . pack <$> str) ( long "enterprise-endpoint" <> short 'e' @@ -163,13 +185,84 @@ <> value Nothing <> help "API endpoint URL for GitHub Enterprise (if applicable)" ) + cmd :: Maybe OwnerName -> RepoName -> PullRequestId -> Token -> Maybe Text + -> Command + cmd owner repo prId token endpoint = + Command readInputFile + (leaveGithubComment owner repo prId token endpoint) +githubCirclePI :: ParserInfo Command +githubCirclePI = info (parser <**> helper) $ + progDesc $ "Create a checklist comment on the corresponding pull " ++ + "reuqest on GitHub from Circle CI. It depends on the " ++ + "following environment variables: CI_PULL_REQUEST, " ++ + "CIRCLE_PROJECT_REPONAME, CIRCLE_PROJECT_USERNAME, CIRCLE_SHA1" + where + parser :: Parser Command + parser = fmap cmd githubTokenOption + cmd :: Token -> Command + cmd token = Command (githubInputReader identifier "CIRCLE_SHA1" token) + (githubCommandRunner identifier token) + identifier :: IO (Maybe OwnerName, RepoName, PullRequestId) + identifier = do + pr <- environ "CI_PULL_REQUEST" + case nonEmpty $ elemIndices '/' pr of + Nothing -> do + System.IO.hPutStrLn stderr "This is not a PR build; skipped..." + exitSuccess -- It shouldn't be marked as failure on CI builds + Just slashes -> do + let lastPart = Prelude.drop + (succ $ Data.List.NonEmpty.last slashes) + pr + prId = mkPullRequestId $ read lastPart + owner <- environ "CIRCLE_PROJECT_USERNAME" + repo <- environ "CIRCLE_PROJECT_REPONAME" + return ( Just $ mkOwnerName $ pack owner + , mkRepoName $ pack repo + , prId + ) + +githubTravisPI :: ParserInfo Command +githubTravisPI = info (parser <**> helper) $ + progDesc $ "Create a checklist comment on the corresponding pull " ++ + "reuqest on GitHub from Travis CI. It depends on the " ++ + "following environment variables: TRAVIS_PULL_REQUEST, " ++ + "TRAVIS_PULL_REQUEST_SHA, TRAVIS_REPO_SLUG." + where + parser :: Parser Command + parser = cmd <$> githubTokenOption + cmd :: Token -> Command + cmd token = Command + (githubInputReader identifier "TRAVIS_PULL_REQUEST_SHA" token) + (githubCommandRunner identifier token) + identifier :: IO (Maybe OwnerName, RepoName, PullRequestId) + identifier = do + pr <- environ "TRAVIS_PULL_REQUEST" + case pr of + "false" -> do + System.IO.hPutStrLn stderr "This is not a PR build; skipped..." + exitSuccess -- It shouldn't be marked as failure on CI builds + _ -> do + let prId = mkPullRequestId $ read pr + slug <- pack <$> environ "TRAVIS_REPO_SLUG" + let (o, r) = Data.Text.break (== '/') slug + owner = mkOwnerName o + repo = mkRepoName $ Data.Text.drop 1 r + return (Just owner, repo, prId) + appPI :: ParserInfo App appPI = info (appP <**> helper) ( fullDesc <> progDesc "Generate checklists relevant to a given patch." ) +environ :: String -> IO String +environ name = do + r <- lookupEnv name + case r of + Nothing -> printError $ pack name `append` " is not defined." + Just v -> return v + printError :: Text -> IO a printError message = do prog <- getProgName @@ -177,11 +270,6 @@ main :: IO () main = do - app@App { appCommand = cmd' } <- execParser appPI - cwd <- getCurrentDirectory - diff <- withInputFile app TIO.hGetContents - case parseDiff diff of - Left msg -> System.IO.putStrLn msg - Right deltas -> do - checklist <- discover cwd deltas - cmd' app checklist + app@App { appCommand = Command { commandRunner = cmd } } <- execParser appPI + checklist <- listChecks app + cmd app checklist diff --git a/checkmate.cabal b/checkmate.cabal --- a/checkmate.cabal +++ b/checkmate.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: checkmate -version: 0.2.1 +version: 0.3.0 synopsis: Generate checklists relevant to a given patch category: Development stability: alpha @@ -43,6 +43,7 @@ , range >= 0.1.2 && < 0.2.0 , text == 1.* , containers >= 0.5.7.1 && < 0.6.0.0 + , github == 0.17.* , monad-parallel >= 0.7.2.2 && < 0.8.0.0 exposed-modules: Checkmate.Check @@ -50,6 +51,7 @@ Checkmate.Discover Checkmate.Parser.CheckFile Checkmate.Parser.IndentBlock + Checkmate.Publisher.GitHub Checkmate.Renderer default-language: Haskell2010 @@ -67,8 +69,8 @@ , range >= 0.1.2 && < 0.2.0 , text == 1.* , checkmate - , github == 0.16.* , optparse-applicative >= 0.13.2.0 && < 0.15.0.0 + , process >= 1.4.3.0 && < 1.5.0.0 if flag(static) ghc-options: -fwarn-incomplete-uni-patterns -threaded -rtsopts -with-rtsopts=-N -static -optl-static -optl-pthread -optc-Os -fPIC else diff --git a/src/Checkmate/Discover.hs b/src/Checkmate/Discover.hs --- a/src/Checkmate/Discover.hs +++ b/src/Checkmate/Discover.hs @@ -1,5 +1,6 @@ module Checkmate.Discover - ( discover + ( FileDeltas + , discover , discoverDirectory , discoverFile , parseDiff @@ -19,8 +20,13 @@ import Checkmate.Parser.CheckFile import Checkmate.Parser.IndentBlock -checkFileName :: FilePath -checkFileName = "CHECK" +checkFileNames :: Set FilePath +checkFileNames = fromList + -- CHECK: All checklist filenames that Checkmate recognize should be + -- written in the project docs (i.e. README.md). + [ "CHECK" + , ".check" + ] discover :: FilePath -> FileDeltas -> IO Checklist discover baseDirPath deltas = do @@ -31,28 +37,30 @@ return . unions $ checklists ++ dirChecklists discoverDirectory :: FilePath -> FilePath -> IO Checklist -discoverDirectory baseDirPath dirPath = do - dirExist <- doesDirectoryExist dirPath' - if not dirExist then return S.empty else do - checkFileExist <- doesFileExist checkFilePath - checklist <- - if checkFileExist - then do - result <- parseCheckFile checkFilePath - return $ case result of - Left _ -> S.empty - Right checklist -> checklist - else return S.empty - parentChecklist <- - if dirPath == "." || dirPath == "" || parent == dirPath - then return S.empty - else discoverDirectory baseDirPath parent - return $ S.union checklist parentChecklist +discoverDirectory baseDirPath dirPath = fmap unions $ forM checkFileNames' $ + \ checkFileName -> do + let checkFilePath = dirPath' checkFileName + dirExist <- doesDirectoryExist dirPath' + if not dirExist then return S.empty else do + checkFileExist <- doesFileExist checkFilePath + checklist <- + if checkFileExist + then do + result <- parseCheckFile checkFilePath + return $ case result of + Left _ -> S.empty + Right checklist -> checklist + else return S.empty + parentChecklist <- + if dirPath == "." || dirPath == "" || parent == dirPath + then return S.empty + else discoverDirectory baseDirPath parent + return $ S.union checklist parentChecklist where + checkFileNames' :: [FilePath] + checkFileNames' = toList checkFileNames dirPath' :: FilePath dirPath' = baseDirPath dirPath - checkFilePath :: FilePath - checkFilePath = dirPath' checkFileName parent :: FilePath parent = takeDirectory dirPath diff --git a/src/Checkmate/Publisher/GitHub.hs b/src/Checkmate/Publisher/GitHub.hs new file mode 100644 --- /dev/null +++ b/src/Checkmate/Publisher/GitHub.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE OverloadedStrings #-} +module Checkmate.Publisher.GitHub + ( Error (..) + , OwnerName + , PullRequestId + , RepoName + , Token + , URL (URL) + , leaveComment + , mkOwnerName + , mkPullRequestId + , mkRepoName + , pullRequestBaseSha + ) where + +import Control.Exception +import Data.Foldable +import Data.Maybe + +import Data.Text hiding (find, null) +import GitHub.Auth +import GitHub.Data.Comments +import GitHub.Data.Definitions +import GitHub.Data.Id +import GitHub.Data.Issues +import GitHub.Data.Name +import GitHub.Data.PullRequests +import GitHub.Data.Repos +import GitHub.Data.URL +import GitHub.Endpoints.Issues.Comments + ( comments' + , createComment + , deleteComment + , editComment + ) +import GitHub.Endpoints.PullRequests (pullRequest) +import GitHub.Endpoints.Users (userInfoCurrent') + +import Checkmate.Check (Checklist) +import Checkmate.Renderer + +type PullRequestId = Id PullRequest +type OwnerName = Name Owner +type RepoName = Name Repo + +mkPullRequestId :: Int -> PullRequestId +mkPullRequestId = Id + +mkOwnerName :: Text -> OwnerName +mkOwnerName = N + +mkRepoName :: Text -> RepoName +mkRepoName = N + +leaveComment :: Maybe OwnerName + -> RepoName + -> PullRequestId + -> Token + -> Maybe Text + -> FilePath + -> Checklist + -> IO (Either Error (Maybe URL)) +leaveComment owner' repo prId accessToken endpoint basePath checklist = try $ do + user <- userInfoCurrent' auth >>= error' + let owner = fromMaybe (N . untagName $ userLogin user) owner' + prComments <- comments' (Just auth) owner repo issueId' >>= error' + let checklistComment = find (isChecklist user) prComments + if null checklist + then + case checklistComment of + Nothing -> return Nothing + Just IssueComment { issueCommentId = cid } -> do + deleteComment auth owner repo (Id cid) >>= error' + return Nothing + else do + let leave = case checklistComment of + Nothing -> createComment auth owner repo issueId' + Just IssueComment { issueCommentId = cid } -> + editComment auth owner repo $ Id cid + Comment { commentHtmlUrl = leftCommentUrl } <- + leave (signature `append` toGFMarkdown basePath 3 checklist) + >>= error' + return leftCommentUrl + where + issueId' :: Id Issue + issueId' = Id $ untagId prId + auth :: Auth + auth = case endpoint of + Nothing -> OAuth accessToken + Just e -> EnterpriseOAuth e accessToken + signature :: Text + signature = "\n" + isChecklist :: User -> IssueComment -> Bool + isChecklist User { userId = uid } + IssueComment { issueCommentBody = cBody + , issueCommentUser = + SimpleUser { simpleUserId = authorId } + } = + uid == authorId && isPrefixOf signature cBody + +pullRequestBaseSha :: Maybe OwnerName + -> RepoName + -> PullRequestId + -> Token + -> Maybe Text + -> IO (Either Error Text) +pullRequestBaseSha owner' repo prId accessToken endpoint = try $ do + user <- userInfoCurrent' auth >>= error' + let owner = fromMaybe (N . untagName $ userLogin user) owner' + PullRequest + { pullRequestBase = PullRequestCommit { pullRequestCommitSha = sha } + } <- pullRequest owner repo prId >>= error' + return sha + where + auth :: Auth + auth = case endpoint of + Nothing -> OAuth accessToken + Just e -> EnterpriseOAuth e accessToken + +error' :: Either Error a -> IO a +error' (Right v) = return v +error' (Left e) = throwIO e