diff --git a/github-tools.cabal b/github-tools.cabal index 5aa709e..5bbcb20 100644 --- a/github-tools.cabal +++ b/github-tools.cabal @@ -94,7 +94,6 @@ library PullRequestInfo PullStatus Requests - Review ghc-options: -Wall build-depends: @@ -113,7 +112,6 @@ library , QuickCheck , quickcheck-text , tabular - , tagsoup , text , time , unordered-containers @@ -131,6 +129,7 @@ executable hub-pulls , bytestring , github >= 0.15.0 , github-tools + , text hs-source-dirs: tools default-language: Haskell2010 diff --git a/src/PullRequestInfo.hs b/src/PullRequestInfo.hs index 0baa5f8..f0a3716 100644 --- a/src/PullRequestInfo.hs +++ b/src/PullRequestInfo.hs @@ -1,11 +1,15 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} module PullRequestInfo where import Control.Monad (join) -import qualified Data.Maybe as Maybe +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.List as List +import Data.Monoid ((<>)) +import Data.Text (Text) import qualified Data.Text as Text import Data.Time.Clock (UTCTime, diffUTCTime) -import qualified GitHub -import qualified Review +import GHC.Generics (Generic) import Text.Html (prettyHtml, toHtml) import Text.Tabular (Header (..), Properties (..), Table (..)) @@ -14,18 +18,35 @@ import qualified Text.Tabular.Html as Html data PullRequestInfo = PullRequestInfo - { repoName :: GitHub.Name GitHub.Repo - , reviewStatus :: [Review.Status] - , pullRequest :: GitHub.PullRequest + { prRepoName :: Text + -- ^ The repository for which the pull request is. + , prNumber :: Int + -- ^ The assigned pull request issue number. + , prUser :: Text + -- ^ The user who proposed this PR. + , prBranch :: Text + -- ^ The branch name from which the pull request came. + , prCreated :: UTCTime + -- ^ Creation time of pull request. I.e. when it was proposed. + , prTitle :: Text + -- ^ Title of pull request. + , prReviewers :: [Text] + -- ^ The list of pull request reviewers (assignees). + , prState :: Text } + deriving (Ord, Eq, Generic) +instance ToJSON PullRequestInfo +instance FromJSON PullRequestInfo -formatPR :: Bool -> UTCTime -> [[PullRequestInfo]] -> String -formatPR False now = AsciiArt.render id id id . prToTable now -formatPR True now = prettyHtml . Html.render toHtml toHtml toHtml . prToTable now +formatPR :: Bool -> UTCTime -> [[PullRequestInfo]] -> Text +formatPR False now = Text.pack . AsciiArt.render Text.unpack Text.unpack Text.unpack . prToTable now +formatPR True now = Text.pack . prettyHtml . Html.render textHtml textHtml textHtml . prToTable now + where textHtml = toHtml . Text.unpack -prToTable :: UTCTime -> [[PullRequestInfo]] -> Table String String String + +prToTable :: UTCTime -> [[PullRequestInfo]] -> Table Text Text Text prToTable now prss = Table rowNames columnNames rows where rowNames = Group SingleLine @@ -34,40 +55,24 @@ prToTable now prss = Table rowNames columnNames rows $ prss getRowName pr = - let repo num = getRepoName pr ++ " " ++ num in - repo . show . GitHub.pullRequestNumber . pullRequest $ pr - - getRepoName = Text.unpack . GitHub.untagName . repoName + let repo num = prRepoName pr <> " " <> num in + repo . Text.pack . show . prNumber $ pr columnNames = Group SingleLine [ Header "branch" , Header "age" , Header "title" - , Header "mergeable" - , Header "mergeable_state" + , Header "state" , Header "review_status" ] - rows = map (\pr -> - [ getPrBranch $ pullRequest pr - , getPrAge $ pullRequest pr - , getPrTitle $ pullRequest pr - , getPrMergeable $ pullRequest pr - , getPrMergeableState $ pullRequest pr - , show $ reviewStatus pr - ]) $ join prss - - getPrTitle = Text.unpack . GitHub.pullRequestTitle - getPrMergeable = show . Maybe.fromMaybe False . GitHub.pullRequestMergeable - getPrMergeableState = show . GitHub.pullRequestMergeableState - - getPrBranch = - Text.unpack - . GitHub.pullRequestCommitLabel - . GitHub.pullRequestHead - - getPrAge = - (++ "d") . show . diffInDays now . GitHub.pullRequestCreatedAt + rows = map (flip map + [ \pr -> prUser pr <> "/" <> prBranch pr + , Text.pack . (++ "d") . show . diffInDays now . prCreated + , prTitle + , prState + , Text.pack . List.intercalate "," . map Text.unpack . prReviewers + ] . flip ($)) $ join prss diffInDays :: UTCTime -> UTCTime -> Int diff --git a/src/PullStatus.hs b/src/PullStatus.hs index 1185ef6..aebf83f 100644 --- a/src/PullStatus.hs +++ b/src/PullStatus.hs @@ -1,7 +1,15 @@ -module PullStatus (getPullStatus) where +{-# LANGUAGE OverloadedStrings #-} +module PullStatus + ( getPullStatus + , getPullInfos + , showPullInfos + ) where import Control.Applicative ((<$>)) 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 @@ -9,10 +17,9 @@ import qualified GitHub.Data.Id as GitHub import Network.HTTP.Client (Manager, newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) -import PullRequestInfo (PullRequestInfo (PullRequestInfo)) +import PullRequestInfo (PullRequestInfo (..)) import qualified PullRequestInfo import Requests -import qualified Review getFullPr @@ -35,16 +42,36 @@ getPrInfo -> GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo -> GitHub.SimplePullRequest - -> IO ([Review.Status], GitHub.PullRequest) + -> IO ([Text], GitHub.PullRequest) getPrInfo auth mgr ownerName repoName pr = do - -- Use assignees as the initial approvals list, all responses unknown. let assignees = V.toList $ GitHub.simplePullRequestAssignees pr - let initApprovals = map (Review.Status Review.Unknown . GitHub.untagName . GitHub.simpleUserLogin) assignees - -- Fetch and parse HTML pages for this PR. - approvals <- Review.approvalsFromHtml initApprovals <$> Review.fetchHtml mgr pr + let reviewers = map (GitHub.untagName . GitHub.simpleUserLogin) assignees -- Get more information that is only in the PullRequest response. fullPr <- getFullPr auth mgr ownerName repoName pr - return (approvals, fullPr) + return (reviewers, fullPr) + + +makePullRequestInfo + :: GitHub.Name GitHub.Repo + -> ([Text], GitHub.PullRequest) + -> PullRequestInfo +makePullRequestInfo repoName (reviewers, pr) = PullRequestInfo + { prRepoName = GitHub.untagName repoName + , prNumber = GitHub.pullRequestNumber pr + , prUser = user + , prBranch = Text.tail branch + , prCreated = GitHub.pullRequestCreatedAt pr + , prTitle = GitHub.pullRequestTitle pr + , prReviewers = reviewers + , prState = showMergeableState $ GitHub.pullRequestMergeableState pr + } + where + (user, branch) = Text.breakOn ":" . GitHub.pullRequestCommitLabel . GitHub.pullRequestHead $ pr + + showMergeableState GitHub.StateClean = "clean" + showMergeableState GitHub.StateDirty = "dirty" + showMergeableState GitHub.StateUnknown = "unknown" + showMergeableState GitHub.StateUnstable = "unstable" getPrsForRepo @@ -59,16 +86,15 @@ getPrsForRepo auth mgr ownerName repoName = do prInfos <- Parallel.mapM (getPrInfo auth mgr ownerName repoName) simplePRs - return $ map (uncurry $ PullRequestInfo repoName) prInfos + return $ map (makePullRequestInfo repoName) prInfos -getPullStatus +getPullInfos :: GitHub.Name GitHub.Organization -> GitHub.Name GitHub.Owner - -> Bool -> Maybe GitHub.Auth - -> IO String -getPullStatus orgName ownerName wantHtml auth = do + -> IO [[PullRequestInfo]] +getPullInfos orgName ownerName auth = do -- Initialise HTTP manager so we can benefit from keep-alive connections. mgr <- newManager tlsManagerSettings @@ -76,8 +102,20 @@ getPullStatus orgName ownerName wantHtml auth = do repos <- V.toList <$> request auth mgr (GitHub.organizationReposR orgName GitHub.RepoPublicityAll GitHub.FetchAll) let repoNames = map GitHub.repoName repos - infos <- Parallel.mapM (getPrsForRepo auth mgr ownerName) repoNames + filter (not . null) . List.sort <$> Parallel.mapM (getPrsForRepo auth mgr ownerName) repoNames + +showPullInfos :: Bool -> [[PullRequestInfo]] -> IO Text +showPullInfos wantHtml infos = -- Pretty-print table with information. - now <- getCurrentTime - return $ PullRequestInfo.formatPR wantHtml now infos + flip (PullRequestInfo.formatPR wantHtml) infos <$> getCurrentTime + + +getPullStatus + :: GitHub.Name GitHub.Organization + -> GitHub.Name GitHub.Owner + -> Bool + -> Maybe GitHub.Auth + -> IO Text +getPullStatus orgName ownerName wantHtml auth = + getPullInfos orgName ownerName auth >>= showPullInfos wantHtml diff --git a/src/Review.hs b/src/Review.hs deleted file mode 100644 index 733a1a6..0000000 --- a/src/Review.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Review where - -import Control.Applicative ((<$>)) -import qualified Data.ByteString.Lazy as LBS -import Data.Function (on) -import qualified Data.List as List -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Text.Encoding (decodeUtf8) -import qualified GitHub -import Network.HTTP.Client (Manager, httpLbs, parseRequest, - responseBody) -import Text.HTML.TagSoup (parseTags) -import Text.HTML.TagSoup.Tree (TagTree (..), tagTree) - - -data Approval - = Approved - | Rejected - | Unknown - deriving (Show) - -data Status = Status - { _reviewerStatus :: Approval - , reviewerName :: Text - } - -instance Show Status where - show (Status Approved name) = '+' : read (show name) - show (Status Rejected name) = '-' : read (show name) - show (Status Unknown name) = read (show name) - - -fetchHtml :: Manager -> GitHub.SimplePullRequest -> IO Text -fetchHtml mgr pr = do - let url = Text.unpack $ GitHub.getUrl $ GitHub.simplePullRequestHtmlUrl pr - -- hPutStrLn stderr $ "fetching " ++ url - req <- parseRequest url - decodeUtf8 . LBS.toStrict . responseBody <$> httpLbs req mgr - - -collectDiscussionItems :: TagTree Text -> [(Text, Text)] -collectDiscussionItems = reverse . go [] - where - go acc TagLeaf {} = acc - - go acc (TagBranch "div" [("class", cls)] (_ : TagBranch "div" _ (_ : TagBranch "a" [("href", name)] _ : _) : _)) - | Text.isInfixOf "discussion-item-review" cls = (cls, Text.tail name) : acc - go acc (TagBranch _ _ body) = - foldl go acc body - - -extractApprovals :: [Status] -> [(Text, Text)] -> [Status] -extractApprovals = foldl extract - where - extract acc (cls, name) - | Text.isInfixOf "is-rejected" cls = Status Rejected name : acc - | Text.isInfixOf "is-approved" cls = Status Approved name : acc - | otherwise = acc - - -approvalsFromHtml :: [Status] -> Text -> [Status] -approvalsFromHtml statuses = - nubWith reviewerName - . extractApprovals statuses - . collectDiscussionItems - . TagBranch "xml" [] - . tagTree - . parseTags - where - nubWith f = List.nubBy ((==) `on` f) diff --git a/tools/hub-pulls.hs b/tools/hub-pulls.hs index dc5e020..266098b 100644 --- a/tools/hub-pulls.hs +++ b/tools/hub-pulls.hs @@ -3,6 +3,7 @@ module Main (main) where import Control.Applicative ((<$>)) import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Text as Text import qualified GitHub import System.Environment (getEnv, lookupEnv) @@ -17,4 +18,4 @@ main = do -- Check if we need to produce HTML or ASCII art. wantHtml <- (/= Nothing) <$> lookupEnv "GITHUB_WANT_HTML" - putStrLn =<< getPullStatus "TokTok" "TokTok" wantHtml auth + putStrLn . Text.unpack =<< getPullStatus "TokTok" "TokTok" wantHtml auth diff --git a/web/TokTok/Hello.hs b/web/TokTok/Hello.hs index 5c69950..f1db696 100644 --- a/web/TokTok/Hello.hs +++ b/web/TokTok/Hello.hs @@ -9,6 +9,7 @@ module TokTok.Hello (newApp) where import Control.Applicative ((<$>), (<*>)) +import Control.Monad.Trans (lift) import Data.Aeson (FromJSON, ToJSON) import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as LBS @@ -26,13 +27,14 @@ import Servant import System.Environment (getEnv) import qualified Changelogs +import PullRequestInfo (PullRequestInfo) import qualified PullStatus data ApiContext = ApiContext { getChangelog :: Changelogs.ChangeLog , getRoadmap :: Changelogs.ChangeLog - , getPulls :: Text + , pullInfos :: [[PullRequestInfo]] } @@ -43,7 +45,7 @@ newContext = do ApiContext <$> Changelogs.fetchChangeLog False "TokTok" "c-toxcore" Nothing <*> Changelogs.fetchChangeLog True "TokTok" "c-toxcore" Nothing - <*> (Text.pack <$> PullStatus.getPullStatus "TokTok" "TokTok" True auth) + <*> PullStatus.getPullInfos "TokTok" "TokTok" auth -- * Example @@ -68,7 +70,8 @@ type TestApi = :<|> "changelog" :> Get '[PlainText] Text :<|> "roadmap" :> Get '[PlainText] Text - :<|> "pulls" :> Get '[HTML] Text + :<|> "pulls.html" :> Get '[HTML] Text + :<|> "pulls" :> Get '[JSON] [[PullRequestInfo]] -- POST /greet with a Greet as JSON in the request body, -- returns a Greet as JSON @@ -91,6 +94,7 @@ server ctx = helloH :<|> changelogH False :<|> changelogH True + :<|> pullsHtmlH :<|> pullsH :<|> postGreetH :<|> deleteGreetH @@ -102,7 +106,8 @@ server ctx = changelogH False = return $ Changelogs.formatChangeLog False (getChangelog ctx) changelogH True = return $ Changelogs.formatChangeLog True (getRoadmap ctx) - pullsH = return $ getPulls ctx + pullsHtmlH = lift $ PullStatus.showPullInfos True $ pullInfos ctx + pullsH = return $ pullInfos ctx postGreetH = return