perf: Some more optimisations: make fewer calls to GH API.

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

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

tools/hub-automerge.hs

@@ -2,20 +2,18 @@
 {-# 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 ()
 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]"

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 ()

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