From 4b19a87e07c9b7d19cdb2aca35d51e5777623ffd Mon Sep 17 00:00:00 2001 From: iphydf Date: Sun, 18 Dec 2016 03:25:48 +0000 Subject: [PATCH] Renamed tools to hub-* and added "roadmap" tool. Fixes #21. --- github-tools.cabal | 21 +++++-- src/Changelogs.hs | 71 ++++++++++++++++-------- tools/{changelog.hs => hub-changelog.hs} | 2 +- tools/{pull-status.hs => hub-pulls.hs} | 0 tools/hub-roadmap.hs | 29 ++++++++++ web/TokTok/Hello.hs | 14 +++-- 6 files changed, 103 insertions(+), 34 deletions(-) rename tools/{changelog.hs => hub-changelog.hs} (89%) rename tools/{pull-status.hs => hub-pulls.hs} (100%) create mode 100644 tools/hub-roadmap.hs diff --git a/github-tools.cabal b/github-tools.cabal index d0af724..8bd1d8a 100644 --- a/github-tools.cabal +++ b/github-tools.cabal @@ -45,8 +45,8 @@ library hs-source-dirs: src default-language: Haskell2010 -executable pull-status - main-is: pull-status.hs +executable hub-pulls + main-is: hub-pulls.hs ghc-options: -Wall build-depends: @@ -57,8 +57,21 @@ executable pull-status hs-source-dirs: tools default-language: Haskell2010 -executable changelog - main-is: changelog.hs +executable hub-changelog + main-is: hub-changelog.hs + ghc-options: + -Wall + build-depends: + base >= 4 && < 5 + , github-tools + , bytestring + , github >= 0.15.0 + , text + hs-source-dirs: tools + default-language: Haskell2010 + +executable hub-roadmap + main-is: hub-roadmap.hs ghc-options: -Wall build-depends: diff --git a/src/Changelogs.hs b/src/Changelogs.hs index c95d7d5..baebeee 100644 --- a/src/Changelogs.hs +++ b/src/Changelogs.hs @@ -9,6 +9,7 @@ module Changelogs import Control.Applicative ((<$>), (<*>)) import Control.Arrow (first, second, (&&&)) import Data.List (foldl') +import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Maybe as Maybe import Data.Monoid ((<>)) @@ -26,9 +27,13 @@ import Requests newtype ChangeLog = ChangeLog { unChangeLog :: [(Text, [Text], [Text])] } -formatChangeLog :: ChangeLog -> Text -formatChangeLog = (<> "\n") . foldl' (<>) "" . map formatMilestone . unChangeLog +formatChangeLog :: Bool -> ChangeLog -> Text +formatChangeLog wantRoadmap = + (<> "\n") . foldl' (<>) "" . map formatMilestone . unChangeLog where + issuesWord = if wantRoadmap then "Planned tasks" else "Closed issues" + prsWord = if wantRoadmap then "PRs to review" else "Merged PRs" + formatMilestone (milestone, issues, pulls) = "\n\n## " <> milestone <> closedIssues issues @@ -36,11 +41,11 @@ formatChangeLog = (<> "\n") . foldl' (<>) "" . map formatMilestone . unChangeLog closedIssues [] = "" closedIssues issues = - foldl' (<>) "\n\n### Closed issues:\n" . itemise $ issues + foldl' (<>) ("\n\n### " <> issuesWord <> ":\n") . itemise $ issues mergedPrs [] = "" mergedPrs pulls = - foldl' (<>) "\n\n### Merged PRs:\n" . itemise $ pulls + foldl' (<>) ("\n\n### " <> prsWord <> ":\n") . itemise $ pulls itemise = map ("\n- " <>) @@ -65,38 +70,54 @@ formatChangeLogItem ownerName repoName item = number = Text.pack . show . clNumber $ item -makeChangeLog :: GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo -> [GitHub.SimplePullRequest] -> [GitHub.Issue] -> ChangeLog -makeChangeLog ownerName repoName pulls issues = +makeChangeLog :: Bool -> GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo -> [GitHub.SimplePullRequest] -> [GitHub.Issue] -> ChangeLog +makeChangeLog wantRoadmap ownerName repoName pulls issues = ChangeLog + . sortChangelog . Map.foldlWithKey (\changes milestone (msIssues, msPulls) -> - ( milestone - , map (formatChangeLogItem ownerName repoName) msIssues - , map (formatChangeLogItem ownerName repoName) msPulls - ) : changes + if milestone == "meta" + then changes + else + ( milestone + , map (formatChangeLogItem ownerName repoName) msIssues + , map (formatChangeLogItem ownerName repoName) msPulls + ) : changes ) [] . groupByMilestone (first . (:)) changeLogIssues . groupByMilestone (second . (:)) changeLogPrs $ Map.empty where - mergedPrs = filter (\case + sortChangelog = + if wantRoadmap + then reverse + else id + + (mergedPrs, openPrs) = List.partition (\case GitHub.SimplePullRequest - { GitHub.simplePullRequestMergedAt = Just _ - } -> True + { GitHub.simplePullRequestMergedAt = Just _ } -> True _ -> False ) pulls - closedItems = filter (\case + selectedPrs = + if wantRoadmap + then openPrs + else mergedPrs + + selectedItems = filter (\case GitHub.Issue { GitHub.issueMilestone = Just GitHub.Milestone - { GitHub.milestoneState = "closed" } - } -> True + { GitHub.milestoneState = state } + } -> + if wantRoadmap + then state == "open" + else state == "closed" _ -> False ) issues milestoneByIssueId = Map.fromList . map (GitHub.issueNumber &&& GitHub.milestoneTitle . Maybe.fromJust . GitHub.issueMilestone) - $ closedItems + $ selectedItems changeLogIssues :: [ChangeLogItem] changeLogIssues = Maybe.mapMaybe (\case @@ -107,7 +128,7 @@ makeChangeLog ownerName repoName pulls issues = , clTitle = GitHub.issueTitle issue , clNumber = GitHub.issueNumber issue } - ) closedItems + ) selectedItems changeLogPrs :: [ChangeLogItem] changeLogPrs = Maybe.mapMaybe (\issue -> do @@ -117,7 +138,7 @@ makeChangeLog ownerName repoName pulls issues = , clTitle = GitHub.simplePullRequestTitle issue , clNumber = GitHub.simplePullRequestNumber issue } - ) mergedPrs + ) selectedPrs groupByMilestone add = flip $ foldr (\item group -> Map.insert (clMilestone item) ( @@ -128,14 +149,16 @@ makeChangeLog ownerName repoName pulls issues = ) -fetchChangeLog :: GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo -> Maybe GitHub.Auth -> IO ChangeLog -fetchChangeLog ownerName repoName auth = do +fetchChangeLog :: Bool -> GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo -> Maybe GitHub.Auth -> IO ChangeLog +fetchChangeLog wantRoadmap ownerName repoName auth = do -- Initialise HTTP manager so we can benefit from keep-alive connections. mgr <- newManager tlsManagerSettings - let pulls = V.toList <$> request auth mgr (GitHub.pullRequestsForR ownerName repoName GitHub.stateClosed GitHub.FetchAll) - let issues = V.toList <$> request auth mgr (GitHub.issuesForRepoR ownerName repoName (GitHub.stateClosed <> GitHub.optionsAnyMilestone) GitHub.FetchAll) + let pulls state = V.toList <$> request auth mgr (GitHub.pullRequestsForR ownerName repoName state GitHub.FetchAll) + let issues state = V.toList <$> request auth mgr (GitHub.issuesForRepoR ownerName repoName (state <> GitHub.optionsAnyMilestone) GitHub.FetchAll) -- issues >>= putStrLn . groom - makeChangeLog ownerName repoName <$> pulls <*> issues + if wantRoadmap + then makeChangeLog wantRoadmap ownerName repoName <$> pulls GitHub.stateOpen <*> issues GitHub.stateOpen + else makeChangeLog wantRoadmap ownerName repoName <$> pulls GitHub.stateClosed <*> issues GitHub.stateClosed diff --git a/tools/changelog.hs b/tools/hub-changelog.hs similarity index 89% rename from tools/changelog.hs rename to tools/hub-changelog.hs index 9e601c3..9aa9779 100644 --- a/tools/changelog.hs +++ b/tools/hub-changelog.hs @@ -18,7 +18,7 @@ main = do -- Get auth token from the $GITHUB_TOKEN environment variable. auth <- fmap (GitHub.OAuth . BS8.pack) <$> lookupEnv "GITHUB_TOKEN" - fetchChangeLog ownerName repoName auth >>= putStr . Text.unpack . formatChangeLog + fetchChangeLog False ownerName repoName auth >>= putStr . Text.unpack . formatChangeLog False where repoLocation [] = diff --git a/tools/pull-status.hs b/tools/hub-pulls.hs similarity index 100% rename from tools/pull-status.hs rename to tools/hub-pulls.hs diff --git a/tools/hub-roadmap.hs b/tools/hub-roadmap.hs new file mode 100644 index 0000000..9aa9779 --- /dev/null +++ b/tools/hub-roadmap.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Control.Applicative ((<$>)) +import qualified Data.ByteString.Char8 as BS8 +import Data.String (fromString) +import qualified Data.Text as Text +import qualified GitHub +import System.Environment (getArgs, lookupEnv) + +import Changelogs + + +main :: IO () +main = do + (ownerName, repoName) <- getArgs >>= repoLocation + + -- Get auth token from the $GITHUB_TOKEN environment variable. + auth <- fmap (GitHub.OAuth . BS8.pack) <$> lookupEnv "GITHUB_TOKEN" + + fetchChangeLog False ownerName repoName auth >>= putStr . Text.unpack . formatChangeLog False + + where + repoLocation [] = + return ("TokTok", "c-toxcore") + repoLocation [ownerName, repoName] = + return (fromString ownerName, fromString repoName) + repoLocation _ = + fail "Usage: changelog " diff --git a/web/TokTok/Hello.hs b/web/TokTok/Hello.hs index 6501d3e..7f11b3e 100644 --- a/web/TokTok/Hello.hs +++ b/web/TokTok/Hello.hs @@ -6,7 +6,7 @@ {-# LANGUAGE TypeOperators #-} module TokTok.Hello (newApp) where -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<*>)) import Control.Monad.Trans (lift) import Data.Aeson (FromJSON, ToJSON) import Data.IORef (IORef) @@ -21,12 +21,14 @@ import qualified Changelogs data ApiContext = ApiContext { getChangelog :: IORef Changelogs.ChangeLog + , getRoadmap :: IORef Changelogs.ChangeLog } newContext :: IO ApiContext newContext = ApiContext - <$> (IORef.newIORef =<< Changelogs.fetchChangeLog "TokTok" "c-toxcore" Nothing) + <$> (IORef.newIORef =<< Changelogs.fetchChangeLog False "TokTok" "c-toxcore" Nothing) + <*> (IORef.newIORef =<< Changelogs.fetchChangeLog True "TokTok" "c-toxcore" Nothing) -- * Example @@ -43,8 +45,8 @@ type TestApi = -- GET /hello/:name?capital={true, false} returns a Greet as JSON "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet - -- GET /hello/:name?capital={true, false} returns a Greet as JSON :<|> "changelog" :> Get '[PlainText] Text + :<|> "roadmap" :> Get '[PlainText] Text -- POST /greet with a Greet as JSON in the request body, -- returns a Greet as JSON @@ -65,7 +67,8 @@ testApi = Proxy server :: ApiContext -> Server TestApi server ctx = helloH - :<|> changelogH + :<|> changelogH False + :<|> changelogH True :<|> postGreetH :<|> deleteGreetH where @@ -73,7 +76,8 @@ server ctx = helloH name (Just False) = return . Greet $ "Hello, " <> name helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name - changelogH = lift $ Changelogs.formatChangeLog <$> IORef.readIORef (getChangelog ctx) + changelogH False = lift $ Changelogs.formatChangeLog False <$> IORef.readIORef (getChangelog ctx) + changelogH True = lift $ Changelogs.formatChangeLog True <$> IORef.readIORef (getRoadmap ctx) postGreetH greet = return greet