{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} 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.Directory (setCurrentDirectory) import System.Process (callProcess) import GitHub.Tools.PullRequestInfo (PullRequestInfo (..)) import GitHub.Tools.PullStatus (getPrInfos, getPullInfos, makePullRequestInfo) import GitHub.Tools.Requests (request) trustedAuthors :: [Text] trustedAuthors = [ "JFreegman" , "TokTok" , "iphydf" , "nurupo" , "robinlinden" , "sudden6" , "zugz" ] workDir :: FilePath workDir = "/tmp/automerge" autoMerge :: String -> GitHub.Name GitHub.Owner -> PullRequestInfo -> IO () autoMerge _ _ PullRequestInfo{prOrigin = Nothing} = return () autoMerge token ownerName PullRequestInfo{prRepoName, prUser, prBranch, prOrigin = Just prOrigin} = do let clonePath = workDir <> "/" <> Text.unpack prRepoName callProcess "rm" ["-rf", clonePath] callProcess "git" [ "clone", "--depth=6" -- 6 so we can merge up to 5 commits on top of the master HEAD commit , "--branch=" <> Text.unpack prBranch , "https://github.com/" <> Text.unpack prUser <> "/" <> Text.unpack prOrigin , clonePath ] setCurrentDirectory clonePath callProcess "git" [ "remote", "add", "upstream" , "https://" <> token <> "@github.com/" <> Text.unpack (GitHub.untagName ownerName) <> "/" <> Text.unpack prRepoName ] callProcess "git" [ "push", "upstream", Text.unpack prBranch <> ":master" ] -- Go back to a directory that will definitely exist even when next time -- we "rm -rf" the git repo cloned above. setCurrentDirectory workDir mergeable :: PullRequestInfo -> Bool mergeable PullRequestInfo{prState, prTrustworthy, prUser} = prState == "clean" && (prTrustworthy || prUser `elem` trustedAuthors) autoMergePullRequest :: String -> GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo -> IO () autoMergePullRequest token ownerName repoName = do let auth = Just . GitHub.OAuth . BS8.pack $ token mgr <- newManager tlsManagerSettings pulls <- (V.toList <$> request auth mgr (GitHub.pullRequestsForR ownerName repoName GitHub.stateOpen GitHub.FetchAll)) >>= fmap (map $ makePullRequestInfo repoName) . getPrInfos auth mgr ownerName repoName putStrLn $ "found " <> show (length pulls) <> " pulls" let mergeablePulls = filter mergeable pulls putStrLn $ "selected " <> show (length mergeablePulls) <> " mergeable pulls:" mapM_ print mergeablePulls mapM_ (autoMerge token ownerName) mergeablePulls autoMergeAll :: GitHub.Name GitHub.Organization -> GitHub.Name GitHub.Owner -> String -> IO () 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