{-# 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 :: [Text]
trustedAuthors =
    [ Text
"Green-Sky"
    , Text
"JFreegman"
    , Text
"TokTok"
    , Text
"iphydf"
    , Text
"nurupo"
    , Text
"robinlinden"
    , Text
"sudden6"
    , Text
"zugz"
    ]


workDir :: FilePath
workDir :: FilePath
workDir = FilePath
"/tmp/automerge"


autoMerge
    :: String
    -> GitHub.Name GitHub.Owner
    -> PullRequestInfo
    -> IO ()
autoMerge :: FilePath -> Name Owner -> PullRequestInfo -> IO ()
autoMerge FilePath
_ Name Owner
_ PullRequestInfo{prOrigin :: PullRequestInfo -> Maybe Text
prOrigin = Maybe Text
Nothing} = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
autoMerge FilePath
token Name Owner
ownerName PullRequestInfo{Text
prRepoName :: PullRequestInfo -> Text
prRepoName :: Text
prRepoName, Text
prUser :: PullRequestInfo -> Text
prUser :: Text
prUser, Text
prBranch :: PullRequestInfo -> Text
prBranch :: Text
prBranch, prOrigin :: PullRequestInfo -> Maybe Text
prOrigin = Just Text
prOrigin} = do
    let clonePath :: FilePath
clonePath = FilePath
workDir FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
Text.unpack Text
prRepoName
    FilePath -> [FilePath] -> IO ()
callProcess FilePath
"rm" [FilePath
"-rf", FilePath
clonePath]
    FilePath -> [FilePath] -> IO ()
callProcess FilePath
"git"
        [ FilePath
"clone", FilePath
"--depth=6"  -- 6 so we can merge up to 5 commits on top of the master HEAD commit
        , FilePath
"--branch=" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
Text.unpack Text
prBranch
        , FilePath
"https://github.com/" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
Text.unpack Text
prUser FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
Text.unpack Text
prOrigin
        , FilePath
clonePath
        ]
    FilePath -> IO ()
setCurrentDirectory FilePath
clonePath

    FilePath -> [FilePath] -> IO ()
callProcess FilePath
"git"
        [ FilePath
"remote", FilePath
"add", FilePath
"upstream"
        , FilePath
"https://" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
token FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"@github.com/" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
Text.unpack (Name Owner -> Text
forall entity. Name entity -> Text
GitHub.untagName Name Owner
ownerName) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
Text.unpack Text
prRepoName
        ]
    FilePath -> [FilePath] -> IO ()
callProcess FilePath
"git"
        [ FilePath
"push", FilePath
"upstream", Text -> FilePath
Text.unpack Text
prBranch FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
":master" ]

    -- Go back to a directory that will definitely exist even when next time
    -- we "rm -rf" the git repo cloned above.
    FilePath -> IO ()
setCurrentDirectory FilePath
workDir


mergeable :: PullRequestInfo -> Bool
mergeable :: PullRequestInfo -> Bool
mergeable PullRequestInfo{Text
prState :: PullRequestInfo -> Text
prState :: Text
prState, Bool
prTrustworthy :: PullRequestInfo -> Bool
prTrustworthy :: Bool
prTrustworthy, Text
prUser :: Text
prUser :: PullRequestInfo -> Text
prUser} =
    Text
prState Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"clean" Bool -> Bool -> Bool
&& (Bool
prTrustworthy Bool -> Bool -> Bool
|| Text
prUser Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
trustedAuthors)


autoMergePullRequest
  :: String
  -> GitHub.Name GitHub.Owner
  -> GitHub.Name GitHub.Repo
  -> IO ()
autoMergePullRequest :: FilePath -> Name Owner -> Name Repo -> IO ()
autoMergePullRequest FilePath
token Name Owner
ownerName Name Repo
repoName = do
    let auth :: Maybe Auth
auth = Auth -> Maybe Auth
forall a. a -> Maybe a
Just (Auth -> Maybe Auth)
-> (FilePath -> Auth) -> FilePath -> Maybe Auth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> Auth
GitHub.OAuth (Token -> Auth) -> (FilePath -> Token) -> FilePath -> Auth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Token
BS8.pack (FilePath -> Maybe Auth) -> FilePath -> Maybe Auth
forall a b. (a -> b) -> a -> b
$ FilePath
token
    Manager
mgr <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
    [PullRequestInfo]
pulls <- (Vector SimplePullRequest -> [SimplePullRequest]
forall a. Vector a -> [a]
V.toList (Vector SimplePullRequest -> [SimplePullRequest])
-> IO (Vector SimplePullRequest) -> IO [SimplePullRequest]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Maybe Auth
-> Manager
-> Request 'RO (Vector SimplePullRequest)
-> IO (Vector SimplePullRequest)
forall a.
FromJSON a =>
Maybe Auth -> Manager -> Request 'RO a -> IO a
request Maybe Auth
auth Manager
mgr (Name Owner
-> Name Repo
-> PullRequestMod
-> FetchCount
-> Request 'RO (Vector SimplePullRequest)
forall (k :: RW).
Name Owner
-> Name Repo
-> PullRequestMod
-> FetchCount
-> Request k (Vector SimplePullRequest)
GitHub.pullRequestsForR Name Owner
ownerName Name Repo
repoName PullRequestMod
forall mod. HasState mod => mod
GitHub.stateOpen FetchCount
GitHub.FetchAll))
        IO [SimplePullRequest]
-> ([SimplePullRequest] -> IO [PullRequestInfo])
-> IO [PullRequestInfo]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([([Text], PullRequest)] -> [PullRequestInfo])
-> IO [([Text], PullRequest)] -> IO [PullRequestInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((([Text], PullRequest) -> PullRequestInfo)
-> [([Text], PullRequest)] -> [PullRequestInfo]
forall a b. (a -> b) -> [a] -> [b]
map ((([Text], PullRequest) -> PullRequestInfo)
 -> [([Text], PullRequest)] -> [PullRequestInfo])
-> (([Text], PullRequest) -> PullRequestInfo)
-> [([Text], PullRequest)]
-> [PullRequestInfo]
forall a b. (a -> b) -> a -> b
$ Name Repo -> ([Text], PullRequest) -> PullRequestInfo
makePullRequestInfo Name Repo
repoName) (IO [([Text], PullRequest)] -> IO [PullRequestInfo])
-> ([SimplePullRequest] -> IO [([Text], PullRequest)])
-> [SimplePullRequest]
-> IO [PullRequestInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Auth
-> Manager
-> Name Owner
-> Name Repo
-> [SimplePullRequest]
-> IO [([Text], PullRequest)]
getPrInfos Maybe Auth
auth Manager
mgr Name Owner
ownerName Name Repo
repoName
    FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"found " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show ([PullRequestInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PullRequestInfo]
pulls) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" pulls"

    let mergeablePulls :: [PullRequestInfo]
mergeablePulls = (PullRequestInfo -> Bool) -> [PullRequestInfo] -> [PullRequestInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter PullRequestInfo -> Bool
mergeable [PullRequestInfo]
pulls
    FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"selected " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show ([PullRequestInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PullRequestInfo]
mergeablePulls) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" mergeable pulls:"
    (PullRequestInfo -> IO ()) -> [PullRequestInfo] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PullRequestInfo -> IO ()
forall a. Show a => a -> IO ()
print [PullRequestInfo]
mergeablePulls

    (PullRequestInfo -> IO ()) -> [PullRequestInfo] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath -> Name Owner -> PullRequestInfo -> IO ()
autoMerge FilePath
token Name Owner
ownerName) [PullRequestInfo]
mergeablePulls


autoMergeAll
  :: GitHub.Name GitHub.Organization
  -> GitHub.Name GitHub.Owner
  -> String
  -> IO ()
autoMergeAll :: Name Organization -> Name Owner -> FilePath -> IO ()
autoMergeAll Name Organization
orgName Name Owner
ownerName FilePath
token = do
    let auth :: Maybe Auth
auth = Auth -> Maybe Auth
forall a. a -> Maybe a
Just (Auth -> Maybe Auth)
-> (FilePath -> Auth) -> FilePath -> Maybe Auth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> Auth
GitHub.OAuth (Token -> Auth) -> (FilePath -> Token) -> FilePath -> Auth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Token
BS8.pack (FilePath -> Maybe Auth) -> FilePath -> Maybe Auth
forall a b. (a -> b) -> a -> b
$ FilePath
token
    [PullRequestInfo]
pulls <- (PullRequestInfo -> Bool) -> [PullRequestInfo] -> [PullRequestInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter PullRequestInfo -> Bool
mergeable ([PullRequestInfo] -> [PullRequestInfo])
-> ([[PullRequestInfo]] -> [PullRequestInfo])
-> [[PullRequestInfo]]
-> [PullRequestInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[PullRequestInfo]] -> [PullRequestInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[PullRequestInfo]] -> [PullRequestInfo])
-> IO [[PullRequestInfo]] -> IO [PullRequestInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name Organization
-> Name Owner -> Maybe Auth -> IO [[PullRequestInfo]]
getPullInfos Name Organization
orgName Name Owner
ownerName Maybe Auth
auth
    (PullRequestInfo -> IO ()) -> [PullRequestInfo] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath -> Name Owner -> PullRequestInfo -> IO ()
autoMerge FilePath
token Name Owner
ownerName) [PullRequestInfo]
pulls