diff --git a/src/GitHub/Tools/AutoMerge.hs b/src/GitHub/Tools/AutoMerge.hs index f823d05..e762d9c 100644 --- a/src/GitHub/Tools/AutoMerge.hs +++ b/src/GitHub/Tools/AutoMerge.hs @@ -1,15 +1,25 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -module GitHub.Tools.AutoMerge (autoMergeRepo, autoMergeAll) where +module GitHub.Tools.AutoMerge + ( autoMergePullRequest + , autoMergeAll + , trustedAuthors + ) where +import qualified Data.ByteString.Char8 as BS8 import Data.Text (Text) import qualified Data.Text as Text +import qualified Data.Vector as V import qualified GitHub +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) import System.Posix.Directory (changeWorkingDirectory) import System.Process (callProcess) import GitHub.Tools.PullRequestInfo (PullRequestInfo (..)) -import GitHub.Tools.PullStatus (getPullInfos, getPullInfosFor) +import GitHub.Tools.PullStatus (getPrInfos, getPullInfos, + makePullRequestInfo) +import GitHub.Tools.Requests (request) trustedAuthors :: [Text] @@ -29,11 +39,11 @@ workDir = "/tmp/automerge" autoMerge :: String - -> GitHub.Name GitHub.Organization + -> GitHub.Name GitHub.Owner -> PullRequestInfo -> IO () autoMerge _ _ PullRequestInfo{prOrigin = Nothing} = return () -autoMerge token orgName PullRequestInfo{prRepoName, prUser, prBranch, prOrigin = Just prOrigin} = do +autoMerge token ownerName PullRequestInfo{prRepoName, prUser, prBranch, prOrigin = Just prOrigin} = do let clonePath = workDir <> "/" <> Text.unpack prRepoName callProcess "rm" ["-rf", clonePath] callProcess "git" @@ -46,7 +56,7 @@ autoMerge token orgName PullRequestInfo{prRepoName, prUser, prBranch, prOrigin = callProcess "git" [ "remote", "add", "upstream" - , "https://" <> token <> "@github.com/" <> Text.unpack (GitHub.untagName orgName) <> "/" <> Text.unpack prOrigin + , "https://" <> token <> "@github.com/" <> Text.unpack (GitHub.untagName ownerName) <> "/" <> Text.unpack prOrigin ] callProcess "git" [ "push", "upstream", Text.unpack prBranch <> ":master" ] @@ -61,24 +71,34 @@ mergeable PullRequestInfo{prState, prTrustworthy, prUser} = prState == "clean" && (prTrustworthy || prUser `elem` trustedAuthors) -autoMergeRepo - :: GitHub.Name GitHub.Owner - -> GitHub.Name GitHub.Organization +hasAuthor :: Text -> GitHub.SimplePullRequest -> Bool +hasAuthor author pr = + (GitHub.untagName . GitHub.simpleUserLogin . GitHub.simplePullRequestUser $ pr) == author + + +autoMergePullRequest + :: String + -> GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo - -> String - -> GitHub.Auth + -> Text -> IO () -autoMergeRepo ownerName orgName repoName token auth = do - pulls <- filter mergeable <$> getPullInfosFor ownerName repoName (Just auth) - mapM_ (autoMerge token orgName) pulls +autoMergePullRequest token ownerName repoName author = do + let auth = Just . GitHub.OAuth . BS8.pack $ token + mgr <- newManager tlsManagerSettings + pulls <- (filter (hasAuthor author) . V.toList <$> + request auth mgr (GitHub.pullRequestsForR ownerName repoName GitHub.stateOpen GitHub.FetchAll)) + >>= getPrInfos auth mgr ownerName repoName + + let prInfos = filter mergeable . map (makePullRequestInfo repoName) $ pulls + mapM_ (autoMerge token ownerName) prInfos autoMergeAll :: GitHub.Name GitHub.Organization -> GitHub.Name GitHub.Owner -> String - -> GitHub.Auth -> IO () -autoMergeAll orgName ownerName token auth = do - pulls <- filter mergeable . concat <$> getPullInfos orgName ownerName (Just auth) - mapM_ (autoMerge token orgName) pulls +autoMergeAll orgName ownerName token = do + let auth = Just . GitHub.OAuth . BS8.pack $ token + pulls <- filter mergeable . concat <$> getPullInfos orgName ownerName auth + mapM_ (autoMerge token ownerName) pulls diff --git a/src/GitHub/Tools/PullStatus.hs b/src/GitHub/Tools/PullStatus.hs index 1ce108e..fa753f8 100644 --- a/src/GitHub/Tools/PullStatus.hs +++ b/src/GitHub/Tools/PullStatus.hs @@ -1,8 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} module GitHub.Tools.PullStatus - ( getPullStatus - , getPullInfosFor + ( getPrInfos + , getPullStatus , getPullInfos + , makePullRequestInfo , showPullInfos ) where @@ -49,6 +50,17 @@ getPrInfo auth mgr ownerName repoName pr = do return (reviewers, fullPr) +getPrInfos + :: Maybe GitHub.Auth + -> Manager + -> GitHub.Name GitHub.Owner + -> GitHub.Name GitHub.Repo + -> [GitHub.SimplePullRequest] + -> IO [([Text], GitHub.PullRequest)] +getPrInfos auth mgr ownerName repoName = + Parallel.mapM (getPrInfo auth mgr ownerName repoName) + + makePullRequestInfo :: GitHub.Name GitHub.Repo -> ([Text], GitHub.PullRequest) @@ -90,16 +102,7 @@ getPrsForRepo auth mgr ownerName repoName = -- Get PR list. V.toList <$> request auth mgr (GitHub.pullRequestsForR ownerName repoName GitHub.stateOpen GitHub.FetchAll) -- Get more details about each PR. - >>= Parallel.mapM (getPrInfo auth mgr ownerName repoName)) - -getPullInfosFor - :: GitHub.Name GitHub.Owner - -> GitHub.Name GitHub.Repo - -> Maybe GitHub.Auth - -> IO [PullRequestInfo] -getPullInfosFor ownerName repoName auth = do - mgr <- newManager tlsManagerSettings - getPrsForRepo auth mgr ownerName repoName + >>= getPrInfos auth mgr ownerName repoName) getPullInfos diff --git a/tools/hub-automerge.hs b/tools/hub-automerge.hs index dfa6f97..2fdafcf 100644 --- a/tools/hub-automerge.hs +++ b/tools/hub-automerge.hs @@ -2,12 +2,10 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import qualified Data.ByteString.Char8 as BS8 import Data.String (fromString) -import qualified GitHub import System.Environment (getArgs, getEnv) -import GitHub.Tools.AutoMerge (autoMergeAll, autoMergeRepo) +import GitHub.Tools.AutoMerge (autoMergeAll, autoMergePullRequest) main :: IO () @@ -15,7 +13,7 @@ main = do -- Get auth token from the $GITHUB_TOKEN environment variable. args <- getArgs token <- getEnv "GITHUB_TOKEN" - let auth = GitHub.OAuth . BS8.pack $ token case args of - [] -> autoMergeAll "TokTok" "TokTok" token auth - repos -> mapM_ (\repo -> autoMergeRepo "TokTok" "TokTok" (fromString repo) token auth) repos + [] -> autoMergeAll "TokTok" "TokTok" token + [repo, author] -> autoMergePullRequest token "TokTok" (fromString repo) (fromString author) + _ -> error "Usage: hub-automerge [repo] [author]" diff --git a/web/TokTok/Handlers.hs b/web/TokTok/Handlers.hs index 10340fc..3106fde 100644 --- a/web/TokTok/Handlers.hs +++ b/web/TokTok/Handlers.hs @@ -4,23 +4,27 @@ module TokTok.Handlers ( handleEvent ) where -import qualified Data.ByteString.Char8 as BS8 -import Data.Maybe (fromMaybe) -import qualified GitHub import GitHub.Data.Name (Name (..)) -import GitHub.Tools.AutoMerge (autoMergeRepo) -import GitHub.Types (CheckSuite (..), CheckSuiteEvent (..), +import GitHub.Tools.AutoMerge (autoMergePullRequest, trustedAuthors) +import GitHub.Types (Author (..), CheckCommit (..), + CheckSuite (..), CheckSuiteEvent (..), Payload (..), Repository (..)) import System.Environment (getEnv) handleEvent :: Payload -> IO () -handleEvent (CheckSuiteEventPayload event) - | ("success" ==) . fromMaybe "" . checkSuiteConclusion . checkSuiteEventCheckSuite $ event = do +handleEvent (CheckSuiteEventPayload (CheckSuiteEvent + { checkSuiteEventCheckSuite = CheckSuite + { checkSuiteConclusion = Just "success" + , checkSuiteHeadBranch = branch + , checkSuiteHeadCommit = Just (CheckCommit + { checkCommitCommitter = Author{ authorName = author } + }) + } + , checkSuiteEventRepository = Repository{ repositoryName = repo } + })) | branch /= Just "master" && author `elem` trustedAuthors = do -- Get auth token from the $GITHUB_TOKEN environment variable. token <- getEnv "GITHUB_TOKEN" - let auth = GitHub.OAuth . BS8.pack $ token - let repo = repositoryName . checkSuiteEventRepository $ event - autoMergeRepo "TokTok" "TokTok" (N repo) token auth + autoMergePullRequest token "TokTok" (N repo) author handleEvent _ = return () diff --git a/web/webservice.hs b/web/webservice.hs index 5070867..5990447 100644 --- a/web/webservice.hs +++ b/web/webservice.hs @@ -16,9 +16,9 @@ import qualified TokTok.Webhooks as Webhooks newApp :: IO Application newApp = do - helloApp <- Hello.newApp + helloApp <- simpleCors <$> Hello.newApp return $ mapUrls $ - mount "hello" (simpleCors helloApp) + mount "hello" helloApp <|> mount "webhooks" Webhooks.app