{-# LANGUAGE OverloadedStrings #-}
module GitHub.Tools.PullStatus
  ( getPrInfos
  , getPullStatus
  , getPullInfos
  , makePullRequestInfo
  , showPullInfos
  ) where

import qualified Control.Monad.Parallel       as Parallel
import qualified Data.List                    as List
import           Data.Text                    (Text)
import qualified Data.Text                    as Text
import           Data.Time.Clock              (getCurrentTime)
import qualified Data.Vector                  as V
import qualified GitHub
import           Network.HTTP.Client          (Manager, newManager)
import           Network.HTTP.Client.TLS      (tlsManagerSettings)

import           GitHub.Tools.PullRequestInfo (PullRequestInfo (..))
import qualified GitHub.Tools.PullRequestInfo as PullRequestInfo
import           GitHub.Tools.Requests


getFullPr
  :: Maybe GitHub.Auth
  -> Manager
  -> GitHub.Name GitHub.Owner
  -> GitHub.Name GitHub.Repo
  -> GitHub.SimplePullRequest
  -> IO GitHub.PullRequest
getFullPr :: Maybe Auth
-> Manager
-> Name Owner
-> Name Repo
-> SimplePullRequest
-> IO PullRequest
getFullPr Maybe Auth
auth Manager
mgr Name Owner
owner Name Repo
repo =
  Maybe Auth -> Manager -> Request 'RO PullRequest -> IO PullRequest
forall a.
FromJSON a =>
Maybe Auth -> Manager -> Request 'RO a -> IO a
request Maybe Auth
auth Manager
mgr
    (Request 'RO PullRequest -> IO PullRequest)
-> (SimplePullRequest -> Request 'RO PullRequest)
-> SimplePullRequest
-> IO PullRequest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name Owner -> Name Repo -> IssueNumber -> Request 'RO PullRequest
forall (k :: RW).
Name Owner -> Name Repo -> IssueNumber -> Request k PullRequest
GitHub.pullRequestR Name Owner
owner Name Repo
repo
    (IssueNumber -> Request 'RO PullRequest)
-> (SimplePullRequest -> IssueNumber)
-> SimplePullRequest
-> Request 'RO PullRequest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimplePullRequest -> IssueNumber
GitHub.simplePullRequestNumber


getPrInfo
  :: Maybe GitHub.Auth
  -> Manager
  -> GitHub.Name GitHub.Owner
  -> GitHub.Name GitHub.Repo
  -> GitHub.SimplePullRequest
  -> IO ([Text], GitHub.PullRequest)
getPrInfo :: Maybe Auth
-> Manager
-> Name Owner
-> Name Repo
-> SimplePullRequest
-> IO ([Text], PullRequest)
getPrInfo Maybe Auth
auth Manager
mgr Name Owner
ownerName Name Repo
repoName SimplePullRequest
pr = do
  let assignees :: [SimpleUser]
assignees = Vector SimpleUser -> [SimpleUser]
forall a. Vector a -> [a]
V.toList (Vector SimpleUser -> [SimpleUser])
-> Vector SimpleUser -> [SimpleUser]
forall a b. (a -> b) -> a -> b
$ SimplePullRequest -> Vector SimpleUser
GitHub.simplePullRequestAssignees SimplePullRequest
pr
  let reviewers :: [Text]
reviewers = (SimpleUser -> Text) -> [SimpleUser] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Name User -> Text
forall entity. Name entity -> Text
GitHub.untagName (Name User -> Text)
-> (SimpleUser -> Name User) -> SimpleUser -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleUser -> Name User
GitHub.simpleUserLogin) [SimpleUser]
assignees
  -- Get more information that is only in the PullRequest response.
  PullRequest
fullPr <- Maybe Auth
-> Manager
-> Name Owner
-> Name Repo
-> SimplePullRequest
-> IO PullRequest
getFullPr Maybe Auth
auth Manager
mgr Name Owner
ownerName Name Repo
repoName SimplePullRequest
pr
  ([Text], PullRequest) -> IO ([Text], PullRequest)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text]
reviewers, PullRequest
fullPr)


getPrInfos
  :: Maybe GitHub.Auth
  -> Manager
  -> GitHub.Name GitHub.Owner
  -> GitHub.Name GitHub.Repo
  -> [GitHub.SimplePullRequest]
  -> IO [([Text], GitHub.PullRequest)]
getPrInfos :: Maybe Auth
-> Manager
-> Name Owner
-> Name Repo
-> [SimplePullRequest]
-> IO [([Text], PullRequest)]
getPrInfos Maybe Auth
auth Manager
mgr Name Owner
ownerName Name Repo
repoName =
    (SimplePullRequest -> IO ([Text], PullRequest))
-> [SimplePullRequest] -> IO [([Text], PullRequest)]
forall (m :: * -> *) a b.
MonadParallel m =>
(a -> m b) -> [a] -> m [b]
Parallel.mapM (Maybe Auth
-> Manager
-> Name Owner
-> Name Repo
-> SimplePullRequest
-> IO ([Text], PullRequest)
getPrInfo Maybe Auth
auth Manager
mgr Name Owner
ownerName Name Repo
repoName)


makePullRequestInfo
  :: GitHub.Name GitHub.Repo
  -> ([Text], GitHub.PullRequest)
  -> PullRequestInfo
makePullRequestInfo :: Name Repo -> ([Text], PullRequest) -> PullRequestInfo
makePullRequestInfo Name Repo
repoName ([Text]
reviewers, PullRequest
pr) = PullRequestInfo :: Text
-> Int
-> Text
-> Text
-> UTCTime
-> Text
-> [Text]
-> Text
-> Maybe Text
-> Bool
-> PullRequestInfo
PullRequestInfo
  { prRepoName :: Text
prRepoName    = Name Repo -> Text
forall entity. Name entity -> Text
GitHub.untagName Name Repo
repoName
  , prNumber :: Int
prNumber      = IssueNumber -> Int
GitHub.unIssueNumber (IssueNumber -> Int) -> IssueNumber -> Int
forall a b. (a -> b) -> a -> b
$ PullRequest -> IssueNumber
GitHub.pullRequestNumber PullRequest
pr
  , prUser :: Text
prUser        = Text
user
  , prBranch :: Text
prBranch      = Text -> Text
Text.tail Text
branch
  , prCreated :: UTCTime
prCreated     = PullRequest -> UTCTime
GitHub.pullRequestCreatedAt PullRequest
pr
  , prTitle :: Text
prTitle       = PullRequest -> Text
GitHub.pullRequestTitle PullRequest
pr
  , prReviewers :: [Text]
prReviewers   = [Text]
reviewers
  , prState :: Text
prState       = MergeableState -> Text
forall p. IsString p => MergeableState -> p
showMergeableState (MergeableState -> Text) -> MergeableState -> Text
forall a b. (a -> b) -> a -> b
$ PullRequest -> MergeableState
GitHub.pullRequestMergeableState PullRequest
pr
  , prOrigin :: Maybe Text
prOrigin      = Name Repo -> Text
forall entity. Name entity -> Text
GitHub.untagName (Name Repo -> Text) -> (Repo -> Name Repo) -> Repo -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Repo -> Name Repo
GitHub.repoName (Repo -> Text) -> Maybe Repo -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PullRequestCommit -> Maybe Repo
GitHub.pullRequestCommitRepo (PullRequest -> PullRequestCommit
GitHub.pullRequestHead PullRequest
pr)
  -- TODO(iphydf): The Haskell github package doesn't support this yet.
  -- , prTrustworthy = GitHub.pullRequestAuthorAssociation pr
  , prTrustworthy :: Bool
prTrustworthy = Bool
False
  }
  where
    (Text
user, Text
branch) = Text -> Text -> (Text, Text)
Text.breakOn Text
":" (Text -> (Text, Text))
-> (PullRequest -> Text) -> PullRequest -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PullRequestCommit -> Text
GitHub.pullRequestCommitLabel (PullRequestCommit -> Text)
-> (PullRequest -> PullRequestCommit) -> PullRequest -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PullRequest -> PullRequestCommit
GitHub.pullRequestHead (PullRequest -> (Text, Text)) -> PullRequest -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ PullRequest
pr

    showMergeableState :: MergeableState -> p
showMergeableState MergeableState
GitHub.StateBehind   = p
"behind"
    showMergeableState MergeableState
GitHub.StateBlocked  = p
"blocked"
    showMergeableState MergeableState
GitHub.StateClean    = p
"clean"
    showMergeableState MergeableState
GitHub.StateDirty    = p
"dirty"
    showMergeableState MergeableState
GitHub.StateDraft    = p
"draft"
    showMergeableState MergeableState
GitHub.StateUnknown  = p
"unknown"
    showMergeableState MergeableState
GitHub.StateUnstable = p
"unstable"


getPrsForRepo
  :: Maybe GitHub.Auth
  -> Manager
  -> GitHub.Name GitHub.Owner
  -> GitHub.Name GitHub.Repo
  -> IO [PullRequestInfo]
getPrsForRepo :: Maybe Auth
-> Manager -> Name Owner -> Name Repo -> IO [PullRequestInfo]
getPrsForRepo Maybe Auth
auth Manager
mgr Name Owner
ownerName Name Repo
repoName =
  (([Text], PullRequest) -> PullRequestInfo)
-> [([Text], PullRequest)] -> [PullRequestInfo]
forall a b. (a -> b) -> [a] -> [b]
map (Name Repo -> ([Text], PullRequest) -> PullRequestInfo
makePullRequestInfo Name Repo
repoName) ([([Text], PullRequest)] -> [PullRequestInfo])
-> IO [([Text], PullRequest)] -> IO [PullRequestInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (
      -- Get PR list.
      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)
      -- Get more details about each PR.
      IO [SimplePullRequest]
-> ([SimplePullRequest] -> IO [([Text], PullRequest)])
-> IO [([Text], PullRequest)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Auth
-> Manager
-> Name Owner
-> Name Repo
-> [SimplePullRequest]
-> IO [([Text], PullRequest)]
getPrInfos Maybe Auth
auth Manager
mgr Name Owner
ownerName Name Repo
repoName)


getPullInfos
  :: GitHub.Name GitHub.Organization
  -> GitHub.Name GitHub.Owner
  -> Maybe GitHub.Auth
  -> IO [[PullRequestInfo]]
getPullInfos :: Name Organization
-> Name Owner -> Maybe Auth -> IO [[PullRequestInfo]]
getPullInfos Name Organization
orgName Name Owner
ownerName Maybe Auth
auth = do
  -- Initialise HTTP manager so we can benefit from keep-alive connections.
  Manager
mgr <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings

  -- Get repo list.
  [Repo]
repos <- Vector Repo -> [Repo]
forall a. Vector a -> [a]
V.toList (Vector Repo -> [Repo]) -> IO (Vector Repo) -> IO [Repo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Auth
-> Manager -> Request 'RO (Vector Repo) -> IO (Vector Repo)
forall a.
FromJSON a =>
Maybe Auth -> Manager -> Request 'RO a -> IO a
request Maybe Auth
auth Manager
mgr (Name Organization
-> RepoPublicity -> FetchCount -> Request 'RO (Vector Repo)
forall (k :: RW).
Name Organization
-> RepoPublicity -> FetchCount -> Request k (Vector Repo)
GitHub.organizationReposR Name Organization
orgName RepoPublicity
GitHub.RepoPublicityAll FetchCount
GitHub.FetchAll)
  let repoNames :: [Name Repo]
repoNames = (Repo -> Name Repo) -> [Repo] -> [Name Repo]
forall a b. (a -> b) -> [a] -> [b]
map Repo -> Name Repo
GitHub.repoName [Repo]
repos

  ([PullRequestInfo] -> Bool)
-> [[PullRequestInfo]] -> [[PullRequestInfo]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ([PullRequestInfo] -> Bool) -> [PullRequestInfo] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PullRequestInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[PullRequestInfo]] -> [[PullRequestInfo]])
-> ([[PullRequestInfo]] -> [[PullRequestInfo]])
-> [[PullRequestInfo]]
-> [[PullRequestInfo]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[PullRequestInfo]] -> [[PullRequestInfo]]
forall a. Ord a => [a] -> [a]
List.sort ([[PullRequestInfo]] -> [[PullRequestInfo]])
-> IO [[PullRequestInfo]] -> IO [[PullRequestInfo]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name Repo -> IO [PullRequestInfo])
-> [Name Repo] -> IO [[PullRequestInfo]]
forall (m :: * -> *) a b.
MonadParallel m =>
(a -> m b) -> [a] -> m [b]
Parallel.mapM (Maybe Auth
-> Manager -> Name Owner -> Name Repo -> IO [PullRequestInfo]
getPrsForRepo Maybe Auth
auth Manager
mgr Name Owner
ownerName) [Name Repo]
repoNames


showPullInfos :: Bool -> [[PullRequestInfo]] -> IO Text
showPullInfos :: Bool -> [[PullRequestInfo]] -> IO Text
showPullInfos Bool
wantHtml [[PullRequestInfo]]
infos =
  -- Pretty-print table with information.
  (UTCTime -> [[PullRequestInfo]] -> Text)
-> [[PullRequestInfo]] -> UTCTime -> Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Bool -> UTCTime -> [[PullRequestInfo]] -> Text
PullRequestInfo.formatPR Bool
wantHtml) [[PullRequestInfo]]
infos (UTCTime -> Text) -> IO UTCTime -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime


getPullStatus
  :: GitHub.Name GitHub.Organization
  -> GitHub.Name GitHub.Owner
  -> Bool
  -> Maybe GitHub.Auth
  -> IO Text
getPullStatus :: Name Organization -> Name Owner -> Bool -> Maybe Auth -> IO Text
getPullStatus Name Organization
orgName Name Owner
ownerName Bool
wantHtml Maybe Auth
auth =
  Name Organization
-> Name Owner -> Maybe Auth -> IO [[PullRequestInfo]]
getPullInfos Name Organization
orgName Name Owner
ownerName Maybe Auth
auth IO [[PullRequestInfo]]
-> ([[PullRequestInfo]] -> IO Text) -> IO Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> [[PullRequestInfo]] -> IO Text
showPullInfos Bool
wantHtml